diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,12 +1,42 @@ # Changelog for `langchain-hs` -All notable changes to this project will be documented in this file. +## 0.0.5.0 - 2026-09-10 -The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), -and this project adheres to the -[Haskell Package Versioning Policy](https://pvp.haskell.org/). +### Major Architecture & Ecosystem Evolution -## Unreleased +- **3-Tier Monorepo Architecture**: + - `langchain-hs-core` (0.0.5.0): Zero-dependency pure core with `RunnableTree`, `ChatModel`, `ContentBlock`, `Tool`, `StreamEvent`, and `LangchainT`. + - `langchain-hs-graph` (0.0.5.0): Graph-based state machine engine with `StateGraph`, `StateReducer`, checkpointers, HITL, and multi-agent coordination. + - `langchain-hs` (0.0.5.0): Production integrations for Ollama, OpenAI, Gemini, Vector Stores, MCP, and Observability. +- **Pure AST Pipelines (`RunnableTree`)**: + - The core selling point: Every component implements the `Runnable` typeclass. + - Compose pure GADT abstract syntax trees using `|>>` (sequential composition), `&>&` (parallel fan-out), and `>>>#` (fallback failover) without side effects before interpretation. +- **LangGraph in Haskell (`StateGraph`)**: + - Cyclic state machines with pure state reducers (`StateReducer s`) satisfying monoid associativity laws. + - Thread-safe STM in-memory checkpointer (`MemoryCheckpointer`) and persistent `SQLiteCheckpointer`. + - First-class Human-in-the-Loop (`HITL`) node interruption, inspect/edit state, and resumption via `resumeGraph`. + - Time-travel state replay and Graphviz DOT visualization export. +- **Model Context Protocol (MCP)**: + - Native stdio and HTTP JSON-RPC 2.0 client implementation. + - Dynamic tool inspection and bidirectional schema mapping to Haskell `Tool` definitions. +- **Decoupled Monad Transformer (`LangchainT env m a`)**: + - Removed redundant global config structs in favor of parameterization over custom user environment `env`. + - Complete `MonadReader`, `MonadError`, `MonadIO`, and `MonadTrans` instances. + - OpenTelemetry distributed tracing spans (`withSpan`) and structured JSON telemetry. + - Three-state Circuit Breaker, exponential backoff retries with randomized jitter, and in-memory caching. +- **Dependency & Performance Upgrades**: + - Upgraded to `ollama-haskell` `0.4.1.0` with JSON schema grammar constraints. + - Migrated to `MercuryTechnologies/openai` client. + - Full PVP upper bounds across all packages for Hackage compliance. + +### ⚠️ Breaking Changes from 0.0.3.0 + +- **`LangchainT` is now parameterized over `env`** (`LangchainT env m a` instead of the former implicit `LangchainConfig`). + - Replace `runLangchainT config action` with `runLangchainT env action` where `env` is your custom environment type (use `()` if you have no shared config). + - The `MonadReader env (LangchainT env m)` instance gives you `ask`/`asks` to read your environment from within the monad. +- **`ChatMessage` renamed to `Message`** throughout — update all pattern matches and constructor calls. +- **Agent modules restructured** — `Langchain.Agent` is now split into `Langchain.Agent.ReAct` and `Langchain.Agent.PlanAndExecute` with updated type signatures for tool-call support. +- **Removed `HtmlLoader`, `JsonLoader`, and `WebPageLoader` from `Langchain.DocumentLoader`** — Along with the `tagsoup` dependency. Users can write custom document loaders tailored to their schemas and formats. ## 0.0.3.0 - 2025-11-16 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,96 +1,279 @@ -# 🦜️🔗LangChain Haskell +# 🦜️🔗 LangChain Haskell (`langchain-hs`) -⚡ Building applications with LLMs through composability in Haskell! ⚡ +> **The Pure Functional, Effect-Polymorphic AI Agent & Multi-Agent Graph Engine in Haskell** +> +> *A strictly typed, effect-polymorphic, AI ecosystem built on pure AST pipelines (`RunnableTree`), cyclic state machines (`StateGraph`), Model Context Protocol (MCP), and production observability.* -
-logo image -
+--- -## Introduction +[![Hackage](https://img.shields.io/badge/hackage-0.0.5.0-blue.svg)](https://hackage.haskell.org/package/langchain-hs) +[![GHC](https://img.shields.io/badge/GHC-9.8%2B-purple.svg)](https://www.haskell.org/ghc/) +[![Components](https://img.shields.io/badge/components-20%20verified-brightgreen.svg)](#-20-core-components--verified-targets) +[![Providers](https://img.shields.io/badge/providers-Ollama%20%7C%20OpenAI%20%7C%20Gemini-orange.svg)](#-dual-provider-parity-ollama--openai) +[![License: MIT](https://img.shields.io/badge/License-MIT-yellow.svg)](LICENSE) +[![Whitepaper](https://img.shields.io/badge/whitepaper-read%20now-blueviolet.svg)](whitepaper.md) -LangChain Haskell is a robust port of the original [LangChain](https://github.com/langchain-ai/langchain) library, bringing its powerful natural language processing capabilities to the Haskell ecosystem. This library enables developers to build applications powered by large language models (LLMs) with ease and flexibility. +--- -### [Documentation](https://tusharad.github.io/langchain-hs/docs/) -### [Hackage API reference](https://hackage.haskell.org/package/langchain-hs) +## Why `langchain-hs`? +Modern AI orchestration frameworks often struggle with race conditions, hidden side-effects, fragile dynamic schemas, and uninspectable opaque execution chains. `langchain-hs` brings mathematical precision and functional programming principles to AI development: -## Features +1. **First-Class Runnable AST Composition (`RunnableTree`)**: Every component—models, prompts, tools, chains, retrievers, and parsers—implements the `Runnable` typeclass. Connect components into trees or graphs using type-safe operators: + - `|>>` : Sequential composition (data flows from left to right). + - `&>&` : Parallel fan-out (concurrent evaluation of independent branches). + - `>>>#` : Fallback chains (automatic failover if the primary branch errors). +2. **LangGraph in Haskell (`StateGraph`)**: Full cyclic state machine engine with pure monoidal state reducers (`StateReducer s`), thread-safe STM memory checkpointers (`TVar`), persistent SQLite checkpointers, Human-in-the-Loop (`HITL`) interrupts, and Time-Travel state replay. -- **LLM Integration**: Seamlessly interact with various language models, including OpenAI's GPT series and others. -- **Prompt Templates**: Create and manage dynamic prompts for different tasks. -- **Memory Management**: Implement conversational memory to maintain context across interactions. -- **Agents and Tools**: Develop agents that can utilize tools to perform complex tasks. -- **Document Loaders**: Load and process documents from various sources for use in your applications. -- **Text Splitter**: Components for splitting text into smaller chunks for processing. -- **Output Parser**: Components for parsing and processing the output of LLMs. -- **VectorStore and Retriever**: Mechanism for storing and retrieving document embeddings. - * Includes support for Faiss, a library for efficient similarity search. This integration is available through the separate [`faiss-hs`](https://github.com/tusharad/faiss-hs) repository. -- **Embeddings**: Components for generating vector representations of text. +--- -## Current Supported Providers - - Ollama - - OpenAI - - Huggingface - - OpenAI compatible APIs (LMStudio, OpenRouter, Llama-cpp, Deepseek) - - More to come... +### Monorepo Packages -## Installation +| Package | Directory | Version | Description | +|---|---|---|---| +| `langchain-hs-core` | [`langchain-hs-core/`](./langchain-hs-core) | `0.0.5.0` | Zero-dependency pure core: `RunnableTree`, `ChatModel`, `ContentBlock`, `Tool`, and `LangchainT`. | +| `langchain-hs-graph` | [`langchain-hs-graph/`](./langchain-hs-graph) | `0.0.5.0` | Stateful graph engine: `StateGraph s m`, checkpointers, HITL, time-travel, and parallel nodes. | +| `langchain-hs` | [`./`](./) | `0.0.5.0` | Production ecosystem: Ollama/OpenAI providers, Agents, MCP, Vector Stores, Chains, Observability. | +| `examples` | [`examples/`](./examples) | - | 41 runnable executables covering all 20 components for Ollama and OpenAI. | +| `site` | [`site/`](./site) | - | Hakyll documentation website with live provider toggle and component reference. | -To use LangChain Haskell in your project, add it to your package dependencies. -If you're using Stack, include it in your `package.yaml`: +--- -```yaml -dependencies: - - base < 5 - - langchain-hs +## 20 Core Components & Verified Targets + +| # | Component | Package Layer | Ollama Executable | OpenAI Executable | Documentation | +|:---:|---|---|---|---|:---:| +| 1 | **Chat Models** | `Langchain.Core.Model` | `stack run simpleollama` | `stack run simpleopenai` | [Docs](site/components/chat-models.md) | +| 2 | **Conduit Streaming** | `Langchain.Core.Stream` | `stack run streamollama` | `stack run streamopenai` | [Docs](site/components/streaming.md) | +| 3 | **Langchain Monad** | `Langchain.Core.Monad` | `stack run monadollama` | `stack run monadopenai` | [Docs](site/components/monad.md) | +| 4 | **Tools & Function Calling** | `Langchain.Core.Tool` | `stack run toolollama` | `stack run toolopenai` | [Docs](site/components/tools.md) | +| 5 | **Structured Outputs** | `Langchain.OutputParser` | `stack run jsonollama` | `stack run jsonopenai` | [Docs](site/components/structured-output.md) | +| 6 | **RAG & Embeddings** | `Langchain.Embedding` | `stack run ragollama` | `stack run ragopenai` | [Docs](site/components/rag.md) | +| 7 | **Hybrid Retrievers** | `Langchain.Retriever` | `stack run retrieverollama` | `stack run retrieveropenai` | [Docs](site/components/retrievers.md) | +| 8 | **Memory Systems** | `Langchain.Memory` | `stack run memoryollama` | `stack run memoryopenai` | [Docs](site/components/memory.md) | +| 9 | **Retrieval QA Chains** | `Langchain.Chain.RetrievalQA` | `stack run retrievalqaollama` | `stack run retrievalqaopenai` | [Docs](site/components/retrieval-qa.md) | +| 10 | **Map-Reduce Processing** | `Langchain.Chain.MapReduce` | `stack run mapreduceollama` | `stack run mapreduceopenai` | [Docs](site/components/map-reduce.md) | +| 11 | **ReAct Agent** | `Langchain.Agent.ReAct` | `stack run reactollama` | `stack run reactopenai` | [Docs](site/components/react-agent.md) | +| 12 | **Plan-and-Execute Agent** | `Langchain.Agent.PlanAndExecute` | `stack run planandexecuteollama` | `stack run planandexecuteopenai` | [Docs](site/components/plan-and-execute.md) | +| 13 | **Guardrails & Safety** | `Langchain.Guardrails` | `stack run guardrailollama` | `stack run guardrailopenai` | [Docs](site/components/guardrails.md) | +| 14 | **Resilience & Retries** | `Langchain.Resilience` | `stack run resilienceollama` | `stack run resilienceopenai` | [Docs](site/components/resilience.md) | +| 15 | **Observability & Tracing** | `Langchain.Observability` | `stack run observabilityollama` | `stack run observabilityopenai` | [Docs](site/components/observability.md) | +| 16 | **Model Context Protocol** | `Langchain.MCP.Client` | `stack run mcpollama` | `stack run mcpopenai` | [Docs](site/components/mcp.md) | +| 17 | **StateGraph Workflows** | `Langchain.Graph` | `stack run stategraphollama` | `stack run stategraphopenai` | [Docs](site/components/state-graph.md) | +| 18 | **Multi-Agent Systems** | `Langchain.Graph.MultiAgent` | `stack run multiagentollama` | `stack run multiagentopenai` | [Docs](site/components/multi-agent.md) | +| 19 | **Human-in-the-Loop (HITL)** | `Langchain.Graph.Checkpointer` | `stack run hitlollama` | `stack run hitlopenai` | [Docs](site/components/hitl.md) | +| 20 | **Runnables & AST Composition** | `Langchain.Core.Runnable` | `stack run runnableollama` | `stack run runnableopenai` | [Docs](site/components/runnables.md) | + +--- + +## Code Showcases + +### 1. The Power of Runnables: Pure AST Composition + +Compose complex multi-stage pipelines using typed operators without executing any `IO` until interpretation: + +```haskell +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Langchain.Prelude + +-- Compose pure AST pipelines with (|>>), (&>&), and (>>>#) +pipeline :: RunnableTree IO Text Text +pipeline = + runLambda (\q -> (q, q)) -- duplicate input query + |>> (fetchDocuments &>& generateFollowup) -- parallel branch fan-out + |>> runLambda (\(docs, fup) -> renderPrompt docs fup) -- pure prompt synthesis + |>> (invokeLLM primaryModel >>># invokeLLM backupModel) -- fallback resilience + |>> parseStructuredResponse -- JSON parser + +main :: IO () +main = do + output <- interpret pipeline "Explain Monads in Haskell" + print output ``` -Then, run the build command for your respective build tool to fetch and compile the dependency. -## Quickstart +--- -Here's a simple example demonstrating how to use LangChain Haskell to interact with an LLM: +### 2. Dual-Provider Chat Comparison: Ollama vs OpenAI +#### Ollama (Local & Offline) ```haskell {-# LANGUAGE OverloadedStrings #-} -module Main (main) where +import Control.Monad.Except (runExceptT) +import qualified Data.Text.IO as T +import Langchain.Prelude -import Langchain.LLM.Ollama -import Langchain.LLM.Core -import Langchain.PromptTemplate -import Langchain.Callback -import qualified Data.Map.Strict as Map -import qualified Data.Text as T +main :: IO () +main = do + -- Connect to local Ollama instance (DeepSeek, Llama 3, Gemma) + model <- newOllama "gemma3" defaultConfig + + let msg = [userMessage "Write a poem about functional programming"] + res <- runExceptT $ invoke model msg Nothing + case res of + Left err -> T.putStrLn $ errorMessage err + Right m -> T.putStrLn $ extractMessageText m +``` +*Run:* `stack run simpleollama` +#### OpenAI / OpenRouter (Cloud) +```haskell +{-# LANGUAGE OverloadedStrings #-} +import Control.Monad.Except (runExceptT) +import qualified Data.Text.IO as T +import Langchain.Prelude +import OpenAI.Common (defaultModelName, getOpenRouterModel) + main :: IO () -main = do - let ollamaLLM = Ollama "llama3.2" [stdOutCallback] - prompt = PromptTemplate "Translate the following English text to French: {text}" - input = Map.fromList [("text", "Hello, how are you?")] - - case renderPrompt prompt input of - Left e -> putStrLn $ "Error: " ++ e - Right renderedPrompt -> do - eRes <- generate ollamaLLM renderedPrompt Nothing - case eRes of - Left err -> putStrLn $ "Error: " ++ err - Right response -> putStrLn $ "Translation: " ++ (T.unpack response) +main = do + -- Connect to OpenAI or OpenRouter using environment API key + model <- getOpenRouterModel defaultModelName + + let msg = [userMessage "Write a poem about functional programming"] + res <- runExceptT $ invoke model msg Nothing + case res of + Left err -> T.putStrLn $ errorMessage err + Right m -> T.putStrLn $ extractMessageText m ``` +*Run:* `stack run simpleopenai` -## Projects using langchain-hs +--- -- [ai-chatbot-hs](https://github.com/tusharad/ai-chatbot-hs) +### 3. Stateful Graphs (`StateGraph`): Cyclic Multi-Agent Workflow -## Contributing +```haskell +{-# LANGUAGE OverloadedStrings #-} +import Langchain.Graph.StateGraph +import Langchain.Prelude -Contributions are welcome! If you'd like to contribute, please fork the repository and submit a pull request. -For major changes, please open an issue first to discuss what you'd like to change. +-- Pure state with a list-append reducer +data AgentState = AgentState { messages :: [Message], loopCount :: Int } -## License +-- Build the graph using pure combinators +workflow :: StateGraph AgentState IO +workflow = + addEdge "reviewer" "planner" -- cyclic feedback loop! + $ addConditionalEdge "executor" + (\s -> pure $ if done s then Right endNodeId else Right "reviewer") + $ addEdge "planner" "executor" + $ addEdge startNodeId "planner" + $ addNode "reviewer" (Node reviewerNode replaceFieldReducer) + $ addNode "executor" (Node executorNode replaceFieldReducer) + $ addNode "planner" (Node plannerNode replaceFieldReducer) + $ emptyStateGraph -This project is licensed under the MIT License. See the [LICENSE](LICENSE) file for details. +main :: IO () +main = do + checkpointer <- newMemoryCheckpointer + case compileGraph workflow of + Left err -> print err + Right compiled -> do + result <- runGraph compiled initialState (Just checkpointer) + print result +``` +*Run:* `stack run stategraphollama` or `stack run stategraphopenai` -## Acknowledgements +--- -This project is inspired by and builds upon the original [LangChain](https://github.com/langchain-ai/langchain) library and its various ports in other programming languages. -Special thanks to the developers of those projects for their foundational work. +### 4. Model Context Protocol (MCP) Tools Integration + +Connect Haskell agents to any external MCP server (e.g., Hackage doc search, SQLite, Filesystem, GitHub) over stdio: + +```haskell +{-# LANGUAGE OverloadedStrings #-} +import Langchain.Prelude + +main :: IO () +main = do + -- Connect to any MCP server via stdio JSON-RPC 2.0 + client <- newStdioMcpClient "docker" ["run", "-i", "--rm", "mcp/hackage-doc"] + + -- Discover available tools from server + mcpTools <- listMcpTools client + let nativeTools = map mcpToolToLangchainTool mcpTools + + -- Bind tools to your ReAct or Plan-and-Execute Agent + let agent = createReActAgent model nativeTools defaultAgentConfig + res <- runReActAgent agent "Search Hoogle for the signature of 'traverse'" + print res +``` +*Run:* `stack run mcpollama` or `stack run mcpopenai` + +--- + +## Installation + +### Stack +Add to your `stack.yaml`: +```yaml +extra-deps: + - langchain-hs-core-0.0.5.0 + - langchain-hs-graph-0.0.5.0 + - langchain-hs-0.0.5.0 +``` +Then in your `.cabal` or `package.yaml`: +```yaml +dependencies: + - langchain-hs # full ecosystem (providers, agents, MCP, vector stores) + - langchain-hs-core # pure core only (no HTTP dependencies) + - langchain-hs-graph # graph engine only +``` + +### Cabal +```bash +cabal install langchain-hs +``` + +--- + +## Development & Quality Commands + +The repository enforces strict code quality and formatting via `make`: + +```bash +# Build the entire monorepo and all 41 example executables +stack build + +# Run unit and property-based test suites +stack test + +# Run HLint across all source trees (zero hints policy) +make lint + +# Check code formatting with Fourmolu +make format-check + +# Format all files in-place +make format + +# Build the documentation website (Hakyll) +make site-build + +# Run live documentation server with auto-reload (port 8000) +make site-watch +``` + +--- + +## Documentation & Research + +| Resource | Description | +|:---|:---| +| **[Hackage Docs](https://hackage.haskell.org/package/langchain-hs)** | Full Haddock API reference for all exported modules | +| **[Whitepaper](whitepaper.md)** | Deep technical dive: category theory foundations, algebraic laws, effect-polymorphic design, and advanced multi-agent patterns | +| **[Documentation Website](site/)** | Hakyll site with 20 component pages, live provider toggle, and instant search (`Cmd+K`) | +| **[Examples](examples/)** | 41 runnable executables covering every component for Ollama and OpenAI | + +To build the Haddock API docs locally: +```bash +make docs +# Opens in .stack-work/install/.../doc/index.html +``` + +--- + +## License + +Distributed under the **MIT License**. See [LICENSE](LICENSE) for details. diff --git a/langchain-hs.cabal b/langchain-hs.cabal --- a/langchain-hs.cabal +++ b/langchain-hs.cabal @@ -1,29 +1,26 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.38.1. +-- This file has been generated from package.yaml by hpack version 0.39.6. -- -- see: https://github.com/sol/hpack name: langchain-hs -version: 0.0.3.0 -synopsis: Haskell implementation of Langchain -description: Build LLM-powered applications in Haskell. -category: Web, AI +version: 0.0.5.0 +synopsis: Pure functional LLM agent framework and multi-agent graph engine in Haskell +description: Build LLM-powered applications, ReAct agents, and LangGraph-style stateful workflows in Haskell with zero unsafePerformIO. +category: AI homepage: https://github.com/tusharad/langchain-hs#readme bug-reports: https://github.com/tusharad/langchain-hs/issues -author: tushar +author: Tushar Adhatrao maintainer: tusharadhatrao@gmail.com -copyright: 2025 tushar +copyright: 2025-2026 Tushar Adhatrao license: MIT license-file: LICENSE build-type: Simple tested-with: - GHC == 9.10.1 + GHC == 9.12.4 + , GHC == 9.10.3 , GHC == 9.8.4 - , GHC == 9.6.6 - , GHC == 9.4.8 - , GHC == 9.2.8 - , GHC == 9.0.2 extra-source-files: README.md CHANGELOG.md @@ -34,49 +31,57 @@ library exposed-modules: - Langchain.Agent.Core - Langchain.Agent.Executor - Langchain.Agent.Middleware + Langchain.Agent.PlanAndExecute Langchain.Agent.ReAct - Langchain.Callback + Langchain.Cache.Core + Langchain.Callback.Manager + Langchain.Chain.MapReduce Langchain.Chain.RetrievalQA Langchain.DocumentLoader.Core + Langchain.DocumentLoader.Csv Langchain.DocumentLoader.DirectoryLoader Langchain.DocumentLoader.FileLoader - Langchain.DocumentLoader.PdfLoader Langchain.Embeddings.Core - Langchain.Embeddings.Gemini Langchain.Embeddings.Ollama Langchain.Embeddings.OpenAI - Langchain.Error - Langchain.LLM.Core - Langchain.LLM.Deepseek - Langchain.LLM.Gemini - Langchain.LLM.Huggingface - Langchain.LLM.Internal.Huggingface - Langchain.LLM.Ollama - Langchain.LLM.OpenAI - Langchain.LLM.OpenAICompatible + Langchain.Guardrail.Core + Langchain.MCP.Client Langchain.Memory.Core - Langchain.Memory.TokenBufferMemory + Langchain.Memory.Entity + Langchain.Memory.Summary + Langchain.Observability Langchain.OutputParser.Core - Langchain.PromptTemplate + Langchain.OutputParser.Structured + Langchain.Prelude + Langchain.PromptTemplate.Chat + Langchain.PromptTemplate.Chat.ChatPromptTemplate + Langchain.PromptTemplate.Chat.MessagesPlaceholder + Langchain.PromptTemplate.FewShot + Langchain.PromptTemplate.Prompt + Langchain.PromptTemplate.String + Langchain.Provider.Gemini + Langchain.Provider.Ollama + Langchain.Provider.OpenAI + Langchain.Resilience.CircuitBreaker + Langchain.Resilience.Retry + Langchain.Retriever.BM25 Langchain.Retriever.Core - Langchain.Retriever.MultiQueryRetriever - Langchain.Runnable.Chain - Langchain.Runnable.ConversationChain - Langchain.Runnable.Core - Langchain.Runnable.Utils + Langchain.Retriever.Hybrid Langchain.TextSplitter.Character + Langchain.TextSplitter.Code + Langchain.TextSplitter.Markdown + Langchain.TextSplitter.RecursiveCharacter + Langchain.TextSplitter.Token + Langchain.Tool.Async + Langchain.Tool.Binding Langchain.Tool.Calculator Langchain.Tool.Core - Langchain.Tool.DuckDuckGo - Langchain.Tool.Utils - Langchain.Tool.WebScraper - Langchain.Tool.WikipediaTool - Langchain.Utils + Langchain.Tool.FileSystem + Langchain.Tool.GenericSchema + Langchain.Tool.Shell Langchain.VectorStore.Core Langchain.VectorStore.InMemory + Langchain.VectorStore.SqliteVec other-modules: Paths_langchain_hs hs-source-dirs: @@ -84,76 +89,151 @@ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: aeson ==2.* - , async <3 - , base >=4.7 && <5 - , base64-bytestring ==1.2.* - , bytestring >=0.10 + , async ==2.2.* + , base >=4.17 && <5 + , bytestring >=0.10 && <0.13 , conduit >=1.2 && <1.4 , containers >=0.6 && <0.9 , directory >=1.3.6 && <1.4 - , filepath <2 + , filepath >=1.4 && <2 + , format-heavy ==0.1.* + , http-client ==0.7.* + , http-client-tls >=0.3 && <0.5 , http-conduit ==2.* , http-types >=0.11 && <0.13 - , ollama-haskell >=0.2.1 - , openai >=2.2.1 - , parsec <4 - , pdf-toolbox-document ==0.1.4 - , tagsoup <0.15 + , langchain-hs-core ==0.0.5.* + , langchain-hs-graph ==0.0.5.* + , mtl >=2.2 && <2.4 + , ollama-haskell >=0.4.0.0 && <0.5 + , openai >=2.2.1 && <3 + , process ==1.6.* + , random ==1.2.* + , scientific ==0.3.* + , servant ==0.20.* + , servant-client ==0.20.* + , servant-client-core ==0.20.* + , servant-conduit ==0.16.* + , servant-event-stream ==0.4.* + , sqlite-simple >=0.4.18 && <0.5 + , stm ==2.5.* , text >=1.2 && <3 , time >=1.9 && <1.15 - , transformers - , vector <0.14 + , transformers >=0.5 && <0.7 + , vector >=0.12 && <0.14 default-language: Haskell2010 test-suite langchain-hs-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: + Test.Langchain.Agent.AdvancedAgentsSpec Test.Langchain.Agent.ReAct + Test.Langchain.Cache.CacheSpec + Test.Langchain.Callback.CallbackManagerSpec + Test.Langchain.Chain.ChainsSpec + Test.Langchain.Chain.RetrievalQASpec Test.Langchain.DocumentLoader.Core + Test.Langchain.DocumentLoader.CsvSpec Test.Langchain.DocumentLoader.DirectoryLoader - Test.Langchain.Embeddings.Core - Test.Langchain.LLM.Core - Test.Langchain.LLM.Ollama + Test.Langchain.Error + Test.Langchain.Graph.CompilationSpec + Test.Langchain.Guardrail.GuardrailSpec + Test.Langchain.Integration.FullRagE2ESpec + Test.Langchain.Integration.OllamaChatSpec + Test.Langchain.Integration.OllamaEmbeddingSpec + Test.Langchain.Integration.OllamaStreamSpec + Test.Langchain.Integration.OllamaToolSpec + Test.Langchain.Integration.ReActAgentE2ESpec + Test.Langchain.Integration.StateGraphE2ESpec + Test.Langchain.Integration.StreamingCachingRetryE2ESpec + Test.Langchain.MCP.McpSpec Test.Langchain.Memory.Core + Test.Langchain.Memory.EntitySpec + Test.Langchain.Memory.SummarySpec Test.Langchain.Memory.TokenBufferMemory + Test.Langchain.ObservabilitySpec + Test.Langchain.OutputParser.AdvancedParsersSpec Test.Langchain.OutputParser.Core - Test.Langchain.PromptTemplate + Test.Langchain.PromptTemplate.Chat.ChatPromptTemplateSpec + Test.Langchain.PromptTemplate.Chat.MessagesPlaceholderSpec + Test.Langchain.PromptTemplate.FewShotSpec + Test.Langchain.PromptTemplate.PromptSpec + Test.Langchain.Property.CheckpointerSpec + Test.Langchain.Property.ErrorSpec + Test.Langchain.Property.MessageSpec + Test.Langchain.Property.PromptTemplateSpec + Test.Langchain.Property.RunnableSpec + Test.Langchain.Property.TextSplitterSpec + Test.Langchain.Provider.FixturesSpec + Test.Langchain.Provider.Gemini + Test.Langchain.Provider.Mock + Test.Langchain.Provider.Ollama + Test.Langchain.Provider.OllamaConversionSpec + Test.Langchain.Provider.OpenAI + Test.Langchain.Provider.TestSseServer + Test.Langchain.RegressionSpec + Test.Langchain.Resilience.CircuitBreakerSpec + Test.Langchain.Resilience.RetrySpec + Test.Langchain.Retriever.BM25Spec Test.Langchain.Retriever.Core - Test.Langchain.Runnable.Chains - Test.Langchain.Runnable.ConversationChains - Test.Langchain.Runnable.Core - Test.Langchain.Runnable.Utils + Test.Langchain.Retriever.HybridSpec + Test.Langchain.TestHelpers Test.Langchain.TextSplitter.Character - Test.Langchain.Tool.Core + Test.Langchain.TextSplitter.CodeSpec + Test.Langchain.TextSplitter.MarkdownSpec + Test.Langchain.TextSplitter.RecursiveCharacterSpec + Test.Langchain.TextSplitter.TokenSpec + Test.Langchain.Tool.AdvancedToolsSpec + Test.Langchain.Tool.Calculator + Test.Langchain.Tool.FileSystem + Test.Langchain.Tool.Shell Test.Langchain.VectorStore.Core + Test.Langchain.VectorStore.SqliteVecSpec Paths_langchain_hs hs-source-dirs: test ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: - aeson ==2.* - , async <3 - , base >=4.7 && <5 - , base64-bytestring ==1.2.* - , bytestring >=0.10 + QuickCheck + , aeson + , aeson-qq + , async + , base >=4.17 && <5 + , bytestring , conduit >=1.2 && <1.4 - , containers >=0.6 && <0.9 - , directory >=1.3.6 && <1.4 + , containers + , directory , filepath - , http-conduit ==2.* - , http-types >=0.11 && <0.13 + , format-heavy ==0.1.* + , http-client ==0.7.* + , http-client-tls >=0.3 && <0.5 + , http-conduit + , http-types , langchain-hs - , ollama-haskell >=0.2.1 - , openai >=2.2.1 - , parsec <4 - , pdf-toolbox-document ==0.1.4 - , tagsoup <0.15 + , langchain-hs-core + , langchain-hs-graph + , mtl >=2.2 && <2.4 + , ollama-haskell >=0.4.0.0 && <0.5 + , openai >=2.2.1 && <3 + , process ==1.6.* + , random ==1.2.* + , resourcet >=1.2 && <1.4 + , scientific ==0.3.* + , servant ==0.20.* + , servant-client ==0.20.* + , servant-client-core ==0.20.* + , servant-conduit ==0.16.* + , servant-event-stream ==0.4.* + , sqlite-simple >=0.4.18 && <0.5 + , stm ==2.5.* , tasty , tasty-hunit + , tasty-quickcheck , temporary , text , time >=1.9 && <1.15 - , transformers - , vector <0.14 + , transformers >=0.5 && <0.7 + , vector >=0.12 && <0.14 + , wai + , warp default-language: Haskell2010 diff --git a/src/Langchain/Agent/Core.hs b/src/Langchain/Agent/Core.hs deleted file mode 100644 --- a/src/Langchain/Agent/Core.hs +++ /dev/null @@ -1,303 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -{- | -Module : Langchain.Agent.Core -Description : Core types and abstractions for LangChain agents -Copyright : (c) 2025 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental - -This module provides the foundational types and typeclasses for building agents -in langchain-hs. An LLM Agent runs tools in a loop to achieve a goal. -An agent runs until a stop condition is met - -when the model emits a final output or an iteration limit is reached. --} -module Langchain.Agent.Core - ( -- * Agent Typeclass - Agent (..) - - -- * Agent Actions and Results - , AgentAction (..) - , AgentFinish (..) - , AgentStep (..) - , PlanResult (..) - - -- * Agent State and Configuration - , AgentState (..) - , AgentConfig (..) - , AgentCallbacks (..) - , defaultAgentConfig - , defaultAgentCallbacks - - -- * Tool support - , ToolAcceptingToolCall (..) - - -- * Memory support - , SomeMemory (..) - ) where - -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Aeson -import Data.Map.Strict (Map) -import Data.Text (Text) -import Data.Time (UTCTime) -import GHC.Generics (Generic) -import Langchain.Error (LangchainResult) -import Langchain.LLM.Core (ToolCall) -import Langchain.Memory.Core (BaseMemory) -import Langchain.Tool.Core - --- | Represents an action (ToolCall) that an agent has decided to take. -data AgentAction = AgentAction - { actionToolCall :: [ToolCall] - -- ^ tool call - , actionLog :: Text - -- ^ LLM's response while suggesting the tool call - , actionMetadata :: Map Text Text - -- ^ Additional metadata about the action - } - deriving (Show, Eq) - --- | Represents the final result when an agent completes its task. -data AgentFinish = AgentFinish - { agentOutput :: Text - -- ^ The final answer or result - , finishMetadata :: Map Text Text - -- ^ Additional information about the execution - , finishLog :: Text - -- ^ Final thoughts or reasoning - } - deriving (Show, Eq, Generic, ToJSON, FromJSON) - --- | Represents one step in the agent's execution. -data AgentStep = AgentStep - { stepAction :: AgentAction - -- ^ The action that was executed - , stepObservation :: Text - -- ^ The result/observation from the executed tool call - , stepTimestamp :: UTCTime - -- ^ When this step occurred - } - deriving (Show, Eq) - -{- | -A SomeMemory is a wrapper around any type that implements BaseMemory. - -> data MyMemory = MyMemory { ... } -> instance BaseMemory MyMemory where ... -> -> let memory = MyMemory { ... } -> let someMemory = SomeMemory memory -> -> let msg = defaultMessage { role = System, content = "You are an AI assistant" } -> let someMemory2 = SomeMemory (WindowBufferMemory 5 (NE.fromList [msg])) --} -data SomeMemory where - SomeMemory :: - (BaseMemory m) => - m -> - SomeMemory - -instance Show SomeMemory where - show (SomeMemory _) = "SomeMemory { }" - -{- | Current state of the agent during execution. - -Tracks: -- Memory instance for managing chat history -- Current input being processed -- Number of iterations so far --} -data AgentState = AgentState - { agentMemory :: SomeMemory - -- ^ Memory instance for managing chat history with the LLM - , agentInput :: Text - -- ^ Current user input/query - , agentIterations :: Int - -- ^ Number of iterations so far - } - -instance Show AgentState where - show (AgentState mem inp iters) = - "AgentState { agentMemory = " - ++ show mem - ++ ", agentInput = " - ++ show inp - ++ ", agentIterations = " - ++ show iters - ++ " }" - -data AgentConfig = AgentConfig - { maxIterations :: Int - -- ^ Maximum number of agent steps (default: 15) - , maxExecutionTime :: Maybe Int - -- ^ Maximum execution time in seconds (Nothing = no limit) - , verboseLogging :: Bool - -- ^ Enable verbose logging (default: False) - , stateMemory :: Maybe SomeMemory - {- ^ Configure type of Chat memory you want use. - ^ (default: windowBufferMessages with 100 window size) - -} - } - deriving (Show) - -{- | Callbacks for agent events. -Allows hooking into various points in the agent lifecycle. --} -data AgentCallbacks = AgentCallbacks - { onAgentStart :: Text -> IO () - -- ^ Called when agent starts with the input - , onAgentAction :: AgentAction -> IO () - -- ^ Called before executing an action - , onAgentObservation :: Text -> IO () - -- ^ Called after receiving an observation / result of the tool call - , onAgentFinish :: AgentFinish -> IO () - -- ^ Called when agent completes - , onAgentStep :: AgentStep -> IO () - -- ^ Called after each complete step - } - -{- | -A ToolAcceptingToolCall is a special type of tool that -can be used by an agent to execute a tool call. - -It is a wrapper around a tool type whose input is a ToolCall and output is a Text. -It is user's responsibility wrap your existing tool into this type. - -Example: - -> data AgeFinderTool = AgeFinderTool -> instance Tool AgeFinderTool where -> type Input AgeFinderTool = ToolCall -> type Output AgeFinderTool = Text -> toolName _ = "age_finder" -> toolDescription _ = "Finds the age of a person given their name." -> runTool _ (ToolCall _ _ ToolFunction {..}) = do -> if toolFunctionName == "age_finder" -> then do -> case HM.lookup "name" toolFunctionArguments of -> Nothing -> pure "Unknown" -> Just (String name_) -> pure $ getAge name_ -> _ -> pure "Unknown" -> else pure "Unknown" -> -> getAge name_ = case name_ of -> "Alice" -> "30" -> "Bob" -> "25" -> _ -> "Unknown" --} -data ToolAcceptingToolCall where - ToolAcceptingToolCall :: - ( Tool t - , Input t ~ ToolCall - , Output t ~ Text - ) => - t -> ToolAcceptingToolCall - -instance Eq ToolAcceptingToolCall where - (ToolAcceptingToolCall t1) == (ToolAcceptingToolCall t2) = toolName t1 == toolName t2 - -instance Show ToolAcceptingToolCall where - show (ToolAcceptingToolCall t) = - "ToolAcceptingToolCall { name = " ++ show (toolName t) ++ " }" - -data PlanResult = Continue AgentAction | Done AgentFinish - deriving (Eq, Show) - -{- | Core Agent typeclass. - -An agent is a system that can plan and execute actions to accomplish a task. -Different agent types (ReAct, Plan-and-Execute, etc.) implement this interface. --} -class Agent a where - {- | Plan the next action or finish. - - Given the current state, decide: - - What tool call to make next (Left AgentAction), or - - That the task is complete and return the final result (Right AgentFinish) - -} - plan :: - a -> - AgentState -> - IO (LangchainResult PlanResult) - - -- | Get the tools available to this agent. - getTools :: a -> [ToolAcceptingToolCall] - - -- | Execute a tool. - executeTool :: a -> ToolCall -> IO (LangchainResult Text) - - {- | Prepare the agent for execution. - Initialize any necessary state before starting. - Default implementation does nothing. - -} - initialize :: a -> AgentState -> IO (LangchainResult AgentState) - initialize _ state = pure $ Right state - - {- | Clean up after agent execution. - Release resources, save state, etc. - Default implementation does nothing. - -} - finalize :: a -> AgentState -> IO () - finalize _ _ = pure () - - -- | MonadIO version of plan - planM :: - MonadIO m => - a -> - AgentState -> - m (LangchainResult PlanResult) - planM agent state = liftIO $ plan agent state - - -- | MonadIO version of executeTool - executeToolM :: MonadIO m => a -> ToolCall -> m (LangchainResult Text) - executeToolM a i = liftIO $ executeTool a i - - -- | MonadIO version of initialize - initializeM :: - MonadIO m => - a -> - AgentState -> - m (LangchainResult AgentState) - initializeM agent state = liftIO $ initialize agent state - - -- | MonadIO version of finalize - finalizeM :: MonadIO m => a -> AgentState -> m () - finalizeM agent state = liftIO $ finalize agent state - -{- | Default agent configuration. - -Sensible defaults: -- 15 max iterations -- No time limit -- No verbose logging -- WindowBufferMemory with window size 100 --} -defaultAgentConfig :: AgentConfig -defaultAgentConfig = - AgentConfig - { maxIterations = 15 - , maxExecutionTime = Nothing - , verboseLogging = False - , stateMemory = Nothing - } - -{- | Default agent callbacks (all no-ops). -Useful as a starting point for custom callbacks. --} -defaultAgentCallbacks :: AgentCallbacks -defaultAgentCallbacks = - AgentCallbacks - { onAgentStart = \_ -> pure () - , onAgentAction = \_ -> pure () - , onAgentObservation = \_ -> pure () - , onAgentFinish = \_ -> pure () - , onAgentStep = \_ -> pure () - } diff --git a/src/Langchain/Agent/Executor.hs b/src/Langchain/Agent/Executor.hs deleted file mode 100644 --- a/src/Langchain/Agent/Executor.hs +++ /dev/null @@ -1,261 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} - -{- | -Module : Langchain.Agent.Executor -Description : Agent execution loop and orchestration -Copyright : (c) 2025 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental - -This module provides the execution engine for agents. It orchestrates the -agent planning loop, tool execution, and result collection. - -The executor handles: -- The main agent loop (plan -> execute -> observe) -- Error handling and recovery -- Iteration limits and timeouts -- Callbacks and logging -- State management --} -module Langchain.Agent.Executor - ( -- * Main Execution Functions - runAgentExecutor - - -- * Result Types - , AgentExecutionResult (..) - , ExecutionMetrics (..) - - -- * Utilities - , createInitialState - ) -where - -import Control.Monad (when) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Except -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time (UTCTime, diffUTCTime, getCurrentTime) -import Langchain.Agent.Core -import Langchain.Agent.Middleware -import Langchain.Error - ( LangchainResult - , agentError - ) -import Langchain.LLM.Core -import Langchain.Memory.Core - -data AgentExecutionResult = AgentExecutionResult - { executionFinish :: AgentFinish - -- ^ The final result of the agent execution - , executionSteps :: [AgentStep] - -- ^ All tool calls made and their results - , executionMetrics :: ExecutionMetrics - -- ^ Performance metrics - } - deriving (Show, Eq) - -data ExecutionMetrics = ExecutionMetrics - { metricsIterations :: Int - -- ^ Number of agent iterations - , metricsExecutionTime :: Double - -- ^ Total time in seconds - , metricsToolCalls :: Int - -- ^ Number of tool calls made - , metricsSuccess :: Bool - -- ^ Whether execution completed successfully - } - deriving (Show, Eq) - --- | Create the initial state of the agent with default memory. -createInitialState :: Maybe SomeMemory -> Text -> AgentState -createInitialState mbSomeMemory input = - AgentState - { agentMemory = fromMaybe (SomeMemory defaultMemory) mbSomeMemory - , agentInput = input - , agentIterations = 0 - } - where - defaultMemory = - WindowBufferMemory - { maxWindowSize = 100 - , windowBufferMessages = initialChatMessage "You are a helpful AI assistant." - } - -{- -Returns False if: -- Max iterations reached -- Max execution time exceeded --} -shouldContinue :: AgentConfig -> AgentState -> Double -> Bool -shouldContinue AgentConfig {..} state elapsedSeconds = - iterationsOk && timeOk - where - iterationsOk = agentIterations state < maxIterations - timeOk = case maxExecutionTime of - Nothing -> True - Just maxTime -> elapsedSeconds < fromIntegral maxTime - --- | Helper function to add an action to the state's memory -addActionToState :: AgentState -> AgentAction -> IO (LangchainResult AgentState) -addActionToState state action = - case agentMemory state of - SomeMemory mem -> do - eMemWithAction <- addMessage mem (actionToMsg action) - case eMemWithAction of - Left err -> pure $ Left err - Right memWithAction -> pure $ Right $ state {agentMemory = SomeMemory memWithAction} - where - actionToMsg act = - defaultMessage - { role = Assistant - , content = actionLog act - , messageData = - defaultMessageData - { toolCalls = Just (actionToolCall act) - } - } - --- | Helper function to add observations to the state's memory -addObservationsToState :: AgentState -> [Text] -> IO (LangchainResult AgentState) -addObservationsToState state observations = - case agentMemory state of - SomeMemory mem -> do - eMemsWithObs <- sequenceA <$> traverse (addMessage mem . toolResultToMsg) observations - case eMemsWithObs of - Left err -> pure $ Left err - Right mems -> pure $ Right $ state {agentMemory = SomeMemory (last mems)} - where - toolResultToMsg res = - defaultMessage - { role = Tool - , content = res - } - -executeAgentLoop :: - Agent a => - a -> - AgentConfig -> - AgentCallbacks -> - [AgentMiddleware a] -> - AgentState -> - UTCTime -> - IO (LangchainResult AgentExecutionResult) -executeAgentLoop agent config callbacks middlewares initialState startTime = - loop agent initialState [] - where - loop agent0 state0 steps = runExceptT $ do - currentTime <- liftIO getCurrentTime - let elapsedSeconds = realToFrac $ diffUTCTime currentTime startTime - -- Check termination conditions - if not (shouldContinue config state0 elapsedSeconds) - then do - let err = agentError "Agent execution exceeded limits" Nothing Nothing - ExceptT . pure $ Left err - else do - -- Plan next action - when (verboseLogging config) $ - liftIO $ - putStrLn $ - "[Agent] Planning iteration " <> show (agentIterations state0) - (state1, agent1) <- - ExceptT $ - applyMiddlewares beforeModelCall middlewares (state0, agent0) - plan_ <- ExceptT $ plan agent1 state1 - (state2, agent2) <- - ExceptT $ - applyMiddlewares afterModelCall middlewares (state1, agent1) - case plan_ of - (Done finish) -> do - -- Agent has finished - let metrics = - ExecutionMetrics - { metricsIterations = agentIterations state2 - , metricsExecutionTime = elapsedSeconds - , metricsToolCalls = length steps - , metricsSuccess = True - } - return $ AgentExecutionResult finish steps metrics - (Continue action) -> do - -- add toolCalls in state memory - state3 <- ExceptT $ addActionToState state2 action - -- Execute action - liftIO $ onAgentAction callbacks action - (state4, agent4) <- - ExceptT $ - applyMiddlewares beforeToolCall middlewares (state3, agent2) - when (verboseLogging config) $ - liftIO $ - putStrLn $ - "[Agent] Executing: " <> show (actionToolCall action) - observations <- - ExceptT $ - sequenceA <$> traverse (executeTool agent4) (actionToolCall action) - mapM_ (liftIO . onAgentObservation callbacks) observations - when (verboseLogging config) $ - liftIO $ - putStrLn $ - "[Agent] Observation: " <> mconcat (T.unpack <$> observations) - -- Record step - timestamp <- liftIO getCurrentTime - let newSteps = map (\obs -> AgentStep action obs timestamp) observations - mapM_ (liftIO . onAgentStep callbacks) newSteps - -- Update state memory with tool results and continue - state5 <- - ExceptT $ - addObservationsToState state4 observations - (state6, agent6) <- - ExceptT $ - applyMiddlewares afterToolCall middlewares (state5, agent4) - let newState = - state6 - { agentIterations = agentIterations state6 + 1 - } - ExceptT (loop agent6 newState (steps ++ newSteps)) - -{- | - Runs the agent executor. - - This function initializes the agent, runs the agent loop, and returns the final result. - - Arguments: - - agent: The agent to run - - config: The agent configuration - - callbacks: The agent callbacks - - input: The input to the agent - - Returns: - - The final result of the agent execution - - The execution metrics - - The execution steps --} -runAgentExecutor :: - Agent a => - a -> - AgentConfig -> - AgentCallbacks -> - [AgentMiddleware a] -> - Text -> - IO (LangchainResult AgentExecutionResult) -runAgentExecutor agent0 config callbacks middlewares input = do - startTime <- getCurrentTime - onAgentStart callbacks input - runExceptT $ do - let initialState = createInitialState (stateMemory config) input - state0 <- ExceptT $ initialize agent0 initialState - (state1, agent1) <- - ExceptT $ - applyMiddlewares beforeAgent middlewares (state0, agent0) - result <- - ExceptT $ - executeAgentLoop agent1 config callbacks middlewares state1 startTime - (state2, agent2) <- - ExceptT $ - applyMiddlewares afterAgent middlewares (state1, agent1) - liftIO $ finalize agent2 state2 - liftIO $ onAgentFinish callbacks (executionFinish result) - return result diff --git a/src/Langchain/Agent/Middleware.hs b/src/Langchain/Agent/Middleware.hs deleted file mode 100644 --- a/src/Langchain/Agent/Middleware.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - -{- | -Module : Langchain.Agent.Middleware -Description : Built-in middlewares for LangChain agents -Copyright : (c) 2025 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental - -This module provides a comprehensive set of built-in middlewares for agents, -similar to Python LangChain's middleware system. Middlewares allow you to hook -into various points in the agent execution lifecycle. - -Available middlewares: -- defaultMiddleware: No-op middleware (base implementation) -- humanInLoopMiddleware: Pause for human approval before tool execution -- toolCallLimitMiddleware: Limit the number of tool calls --} -module Langchain.Agent.Middleware - ( -- * Middleware Type - AgentMiddleware (..) - , applyMiddlewares - - -- * Built-in Middlewares - , defaultMiddleware - , humanInLoopMiddleware - , toolCallLimitMiddleware - ) where - -import Control.Monad (foldM) -import Data.IORef (modifyIORef', newIORef, readIORef) -import qualified Data.List.NonEmpty as NE -import qualified Data.Text as T -import Langchain.Agent.Core -import Langchain.Error - ( LangchainResult - , agentError - , fromString - ) -import Langchain.LLM.Core (Message (messageData), MessageData (toolCalls)) -import Langchain.Memory.Core (BaseMemory (messages)) - --- | Middleware hooks around agent execution steps. -data Agent a => AgentMiddleware a = AgentMiddleware - { beforeModelCall :: (AgentState, a) -> IO (LangchainResult (AgentState, a)) - , afterModelCall :: (AgentState, a) -> IO (LangchainResult (AgentState, a)) - , beforeToolCall :: (AgentState, a) -> IO (LangchainResult (AgentState, a)) - , afterToolCall :: (AgentState, a) -> IO (LangchainResult (AgentState, a)) - , beforeAgent :: (AgentState, a) -> IO (LangchainResult (AgentState, a)) - , afterAgent :: (AgentState, a) -> IO (LangchainResult (AgentState, a)) - } - --- | Default middleware that does nothing (no-op). -defaultMiddleware :: Agent a => AgentMiddleware a -defaultMiddleware = - AgentMiddleware - { beforeModelCall = pure . Right - , afterModelCall = pure . Right - , beforeToolCall = pure . Right - , afterToolCall = pure . Right - , beforeAgent = pure . Right - , afterAgent = pure . Right - } - --- | Sequentially apply a list of middlewares for a given phase. -applyMiddlewares :: - (AgentMiddleware a -> (AgentState, a) -> IO (LangchainResult (AgentState, a))) -> - [AgentMiddleware a] -> - (AgentState, a) -> - IO (LangchainResult (AgentState, a)) -applyMiddlewares f mws st = - foldM - ( \acc mw -> case acc of - Left err -> pure $ Left err - Right s -> f mw s - ) - (Right st) - mws - -{- | Human-in-the-loop middleware. -Pauses execution before each tool call and asks for human approval. -This is useful for sensitive operations or debugging. - -Example: -> runAgentExecutor agent config callbacks [humanInLoopMiddleware] "input" --} -humanInLoopMiddleware :: Agent a => AgentMiddleware a -humanInLoopMiddleware = - defaultMiddleware - { beforeToolCall = \(st, a) -> do - case agentMemory st of - SomeMemory mem -> do - eRes <- messages mem - case eRes of - Left err -> pure $ Left err - Right msgs -> do - let msg = NE.last msgs - toolCallLst = toolCalls $ messageData msg - putStrLn $ "Approve this tool call? " ++ show toolCallLst - putStrLn "(y/n): " - resp <- getLine - if resp == "y" - then pure $ Right (st, a) - else pure $ Left $ fromString "Tool call rejected by human" - } - -{- | Tool call limit middleware. -Limits the total number of tool calls during agent execution. -This helps prevent excessive tool usage and control costs. - -Example: -> toolCallLimitMiddleware 20 -- Limit to 20 tool calls --} -toolCallLimitMiddleware :: Agent a => Int -> IO (AgentMiddleware a) -toolCallLimitMiddleware maxCalls = do - counter <- newIORef 0 - pure $ - defaultMiddleware - { beforeToolCall = \(st, a) -> do - count <- readIORef counter - if count >= maxCalls - then - pure $ - Left $ - agentError - (T.pack $ "Tool call limit exceeded: " <> show maxCalls) - Nothing - (Just (T.pack "toolCallLimitMiddleware")) - else do - modifyIORef' counter (+ 1) - pure $ Right (st, a) - } diff --git a/src/Langchain/Agent/PlanAndExecute.hs b/src/Langchain/Agent/PlanAndExecute.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Agent/PlanAndExecute.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | +Module : Langchain.Agent.PlanAndExecute +Description : Plan-and-Execute agent architecture using JSON structured output and effectful step executors +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Separates complex multi-step reasoning into a two-phase architecture: +1. Planner LLM generates an explicit sequence of structured steps as typed JSON. +2. Executor (an agent with tools, a function, or a model) executes each step sequentially with accumulated context. +-} +module Langchain.Agent.PlanAndExecute + ( PlanStep (..) + , Plan (..) + , StepExecutor (..) + , PlanAndExecuteAgent (..) + , newPlanAndExecuteAgent + , newPlanAndExecuteAgentWithTools + , runPlanAndExecute + ) where + +import Control.Applicative ((<|>)) +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.IO.Class (MonadIO) +import Data.Aeson (FromJSON (..), ToJSON, Value (..), withObject, (.!=), (.:), (.:?)) +import Data.Aeson.Types (prependFailure, typeMismatch) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) + +import Langchain.Agent.ReAct (ReActAgent, createReActAgent, runReActAgent) +import Langchain.Core.Error (LangchainError, agentError) +import Langchain.Core.Model + ( ChatModel (..) + , extractMessageText + , userMessage + ) +import Langchain.Core.Tool (Tool) +import Langchain.OutputParser.Structured (StructuredOutput, TypeSchema, structuredInvoke) +import Langchain.Tool.Binding (ToolBinder (..)) + +-- | Single step in an execution plan +data PlanStep = PlanStep + { stepNumber :: !Int + , stepDescription :: !Text + } + deriving stock (Show, Eq, Generic) + deriving anyclass (ToJSON, TypeSchema) + +instance FromJSON PlanStep where + parseJSON = withObject "PlanStep" $ \o -> do + num <- + o .:? "stepNumber" >>= \case + Just n -> pure n + Nothing -> + o .:? "step" >>= \case + Just n -> pure n + Nothing -> o .:? "number" .!= 1 + desc <- + o .:? "stepDescription" >>= \case + Just d -> pure d + Nothing -> + o .:? "description" >>= \case + Just d -> pure d + Nothing -> + o .:? "task" >>= \case + Just d -> pure d + Nothing -> o .: "action" + pure $ PlanStep num desc + +-- | Collection of steps forming a plan +newtype Plan = Plan + { planSteps :: [PlanStep] + } + deriving stock (Show, Eq, Generic) + deriving anyclass (ToJSON, StructuredOutput, TypeSchema) + +instance FromJSON Plan where + parseJSON (Object o) = Plan <$> (o .: "planSteps" <|> o .: "steps" <|> o .: "plan") + parseJSON (Array arr) = Plan <$> parseJSON (Array arr) + parseJSON invalid = prependFailure "parsing Plan failed, " (typeMismatch "Object or Array" invalid) + +-- | Abstraction for executing individual steps of a plan (agents, models with tools, or custom runners) +class StepExecutor e m where + executeStep :: e -> Text -> m Text + +instance + {-# OVERLAPPING #-} + (m ~ n, ToolBinder model m, MonadIO n, MonadError LangchainError n) => + StepExecutor (ReActAgent model m) n + where + executeStep agent prompt = do + msg <- runReActAgent agent [userMessage prompt] + pure $ extractMessageText msg + +instance + {-# OVERLAPPING #-} + (m ~ n, ToolBinder model m, MonadIO n, MonadError LangchainError n) => + StepExecutor (model, [Tool m]) n + where + executeStep (model, tools) prompt = do + let agent = createReActAgent model tools + executeStep agent prompt + +instance {-# OVERLAPPING #-} (m ~ n) => StepExecutor (Text -> m Text) n where + executeStep = id + +instance {-# OVERLAPPABLE #-} (ChatModel model, MonadIO m, MonadError LangchainError m) => StepExecutor model m where + executeStep model prompt = do + msg <- invoke model [userMessage prompt] Nothing + pure $ extractMessageText msg + +-- | Plan-and-Execute agent container +data PlanAndExecuteAgent planner executor = PlanAndExecuteAgent + { plannerModel :: planner + , stepExecutor :: executor + , planPromptTemplate :: Maybe Text + } + +-- | Construct a new PlanAndExecuteAgent with any StepExecutor (agent, function, or model) +newPlanAndExecuteAgent :: + planner -> + executor -> + Maybe Text -> + PlanAndExecuteAgent planner executor +newPlanAndExecuteAgent = PlanAndExecuteAgent + +-- | Construct a PlanAndExecuteAgent with tools using a ReActAgent as the step executor +newPlanAndExecuteAgentWithTools :: + planner -> + model -> + [Tool m] -> + Maybe Text -> + PlanAndExecuteAgent planner (ReActAgent model m) +newPlanAndExecuteAgentWithTools planner model tools = + PlanAndExecuteAgent planner (createReActAgent model tools) + +-- | Execute a goal using the Plan-and-Execute workflow with structured JSON planning +runPlanAndExecute :: + (ChatModel planner, StepExecutor executor m, MonadIO m, MonadError LangchainError m) => + PlanAndExecuteAgent planner executor -> + Text -> + m Text +runPlanAndExecute PlanAndExecuteAgent {..} userGoal = do + let planPrompt = case planPromptTemplate of + Just p -> p <> "\nGoal: " <> userGoal + Nothing -> + "You are an expert planner. For the following goal, generate a concise step-by-step execution plan.\n" + <> "Output JSON format: {\"planSteps\": [{\"stepNumber\": 1, \"stepDescription\": \"...\"}]}\n" + <> "Keep the plan focused and minimal (between 2 to 3 distinct, actionable steps).\n" + <> "Goal: " + <> userGoal + plan <- structuredInvoke plannerModel [userMessage planPrompt] + if null (planSteps plan) + then throwError $ agentError "Planner generated an empty plan" (Just "PlanAndExecuteAgent") Nothing + else executeSteps (planSteps plan) [] + where + executeSteps [] stepOutputs = do + let synthesisPrompt = + "User Goal: " + <> userGoal + <> "\n\nStep Execution History:\n" + <> T.unlines + [T.pack (show num) <> ". " <> desc <> " -> " <> out | (PlanStep num desc, out) <- stepOutputs] + <> "\n\nProvide the final synthesized answer satisfying the goal:" + executeStep stepExecutor synthesisPrompt + executeSteps (currStep : restSteps) prevOutputs = do + let stepPrompt = + "User Goal: " + <> userGoal + <> ( if null prevOutputs + then "" + else + "\n\nCompleted Steps So Far:\n" + <> T.unlines + [T.pack (show num) <> ". " <> desc <> " -> " <> out | (PlanStep num desc, out) <- prevOutputs] + ) + <> "\n\nCurrent Task To Execute (Step " + <> T.pack (show (stepNumber currStep)) + <> "): " + <> stepDescription currStep + <> "\nExecute this task using any appropriate tools available and provide the outcome:" + stepOut <- executeStep stepExecutor stepPrompt + executeSteps restSteps (prevOutputs ++ [(currStep, stepOut)]) diff --git a/src/Langchain/Agent/ReAct.hs b/src/Langchain/Agent/ReAct.hs --- a/src/Langchain/Agent/ReAct.hs +++ b/src/Langchain/Agent/ReAct.hs @@ -1,169 +1,107 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {- | Module : Langchain.Agent.ReAct -Description : ReAct (Reasoning + Acting) agent implementation -Copyright : (c) 2025 Tushar Adhatrao +Description : Effect-polymorphic ReAct (Reasoning + Acting) Agent engine +Copyright : (c) 2025-2026 Tushar Adhatrao License : MIT Maintainer : Tushar Adhatrao Stability : experimental -This module implements the ReAct (Reasoning + Acting) agent pattern. -ReAct combines reasoning traces and task-specific actions in an interleaved manner. +Modernized ReAct agent operating over ChatModel, Tool m, and multi-modal Message history. +Uses 'ToolBinder' to pass tool definitions to the LLM provider in a provider-agnostic way. -} module Langchain.Agent.ReAct - ( -- * Agent Creation - ReActAgent (..) + ( AgentStep (..) + , ReActAgent (..) , createReActAgent - , createReActAgentWithPrompt - - -- * Prompt Templates - , reActSystemPrompt + , reactStep + , runReActAgent ) where -import Control.Monad.Trans.Except +import Control.Monad (forM) +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.IO.Class (MonadIO) import Data.List (find) -import qualified Data.Map as Map -import Data.Text (Text) -import qualified Data.Text as T -import Langchain.Agent.Core -import qualified Langchain.Error as Error -import Langchain.LLM.Core -import Langchain.Memory.Core (BaseMemory (..)) -import Langchain.Tool.Core -{- | ReAct agent. - -Arguments: -- llm: The language model -- llmParams: The language model parameters -- systemPrompt: The system prompt -- maxThinkingSteps: The maximum number of thinking steps before forcing action -- tools: The tools available to the agent. --} -data ReActAgent llm = ReActAgent - { reactLLM :: llm - -- ^ The language model for reasoning - , reactLLMParams :: Maybe (LLMParams llm) - -- ^ the llm params for language model - , reactSystemPrompt :: Text - -- ^ System prompt template - , reactMaxThinkingSteps :: Int - -- ^ Maximum consecutive thinking steps before forcing action (default: 3) - , reactTools :: [ToolAcceptingToolCall] - } - -{- | Create a ReAct agent. +import Langchain.Core.Error (LangchainError, agentError, errorMessage) +import Langchain.Core.Model +import qualified Langchain.Core.Model.Types as M +import Langchain.Core.Tool +import Langchain.Tool.Binding (ToolBinder (..)) -Arguments: -- llm: The language model -- llmParams: The language model parameters -- tools: The tools available to the agent +-- | Step result of ReAct reasoning iteration +data AgentStep + = AgentAction Message [ToolCall] + | AgentFinish Message + deriving (Eq, Show) -Important: -- It is user's responsibility to wrap the tools into ToolAcceptingToolCall. -- It is user's responsibility to pass tool_calls as part of LLMParams. -- The tool_calls shall be same as the reactTools (ToolAcceptingToolCall) list. --} -createReActAgent :: - -- | The language model - llm -> - -- | The language model parameters - Maybe (LLMParams llm) -> - -- | The tools available to the agent - [ToolAcceptingToolCall] -> - -- | The ReAct agent - ReActAgent llm -createReActAgent llm mbLlmParams tools = - ReActAgent - { reactLLM = llm - , reactLLMParams = mbLlmParams - , reactSystemPrompt = reActSystemPrompt - , reactMaxThinkingSteps = 3 - , reactTools = tools - } +-- | Effect-polymorphic ReAct Agent configuration +data ReActAgent model m = ReActAgent + { agentModel :: model + , agentTools :: [Tool m] + , agentMaxIterations :: Int + } --- | Create a ReAct agent with a custom system prompt. -createReActAgentWithPrompt :: - -- | The language model - llm -> - -- | The language model parameters - Maybe (LLMParams llm) -> - -- | The tools available to the agent - [ToolAcceptingToolCall] -> - -- | The custom system prompt - Text -> - -- | The ReAct agent - ReActAgent llm -createReActAgentWithPrompt llm mbLlmParams tools prompt = +-- | Construct a ReAct Agent instance +createReActAgent :: model -> [Tool m] -> ReActAgent model m +createReActAgent model tools = ReActAgent - { reactLLM = llm - , reactLLMParams = mbLlmParams - , reactSystemPrompt = prompt - , reactMaxThinkingSteps = 3 - , reactTools = tools + { agentModel = model + , agentTools = tools + , agentMaxIterations = 10 } --- | Default system prompt for the ReAct agent. -reActSystemPrompt :: Text -reActSystemPrompt = - "You are a helpful AI assistant that uses tools to answer user questions." - -instance LLM llm => Agent (ReActAgent llm) where - plan agent state = do - let llm = reactLLM agent - mbParams = reactLLMParams agent - -- Get messages from memory - use case to handle existential type - case agentMemory state of - SomeMemory mem -> runExceptT $ do - msgs <- ExceptT $ messages mem - respMsg <- ExceptT $ chat llm msgs mbParams - case toolCalls (messageData respMsg) of - Nothing -> do - -- No tool calls requested. Assume content as the final result - pure $ - Done $ - AgentFinish - { agentOutput = content respMsg - , finishMetadata = Map.empty -- TODO: Add stuff from state - , finishLog = content respMsg - } - Just toolCallList -> do - pure $ - Continue - AgentAction - { actionToolCall = toolCallList - , actionLog = content respMsg - , actionMetadata = Map.empty -- TODO: what to add here? - } - - getTools = reactTools - - executeTool agent toolCall = do - let tools = getTools agent - let inputFunctionName = toolFunctionName (toolCallFunction toolCall) - case find (\(ToolAcceptingToolCall t) -> toolName t == inputFunctionName) tools of - Nothing -> - pure $ - Left $ - Error.fromString $ - "Cannot find tool with name: " - <> T.unpack inputFunctionName - Just (ToolAcceptingToolCall selectedTool) -> Right <$> runTool selectedTool toolCall +-- | Run a single step of ReAct reasoning using ChatModel +reactStep :: + forall model m. + (ToolBinder model m, MonadIO m, MonadError LangchainError m) => + model -> + [Tool m] -> + [Message] -> + m AgentStep +reactStep model tools history = do + let cfg = bindToolsConfig @model tools Nothing + responseMsg <- invoke model history cfg + case messageToolCalls responseMsg of + Just tcs@(_ : _) -> pure $ AgentAction responseMsg tcs + _ -> pure $ AgentFinish responseMsg - initialize agent state = do - let sysPrompt = reactSystemPrompt agent - userInput = agentInput state - sysMsg = defaultMessage {role = System, content = sysPrompt} - userMsg = defaultMessage {role = User, content = userInput} - case agentMemory state of - SomeMemory mem -> runExceptT $ do - memWithSys <- ExceptT $ addMessage mem sysMsg - memWithUser <- ExceptT $ addMessage memWithSys userMsg - pure - AgentState - { agentMemory = SomeMemory memWithUser - , agentInput = userInput - , agentIterations = 0 - } +-- | Execute the full ReAct reasoning loop until AgentFinish or max iterations reached +runReActAgent :: + (ToolBinder model m, MonadIO m, MonadError LangchainError m) => + ReActAgent model m -> + [Message] -> + m Message +runReActAgent agent initialHistory = go initialHistory (agentMaxIterations agent) + where + go history maxIter + | maxIter <= 0 = throwError $ agentError "ReAct Agent exceeded maximum iterations" Nothing Nothing + | otherwise = do + step <- reactStep (agentModel agent) (agentTools agent) history + case step of + AgentFinish finalMsg -> pure finalMsg + AgentAction respMsg tcs -> do + obsMsgs <- forM tcs $ \tc -> do + let tName = toolCallName tc + outTxt <- case find (\t -> toolName t == tName) (agentTools agent) of + Nothing -> + pure $ "Error: Tool not found: " <> tName + Just tool -> do + eOut <- toolExecute tool (toolCallArguments tc) + case eOut of + Left err -> + pure $ "Error executing tool " <> tName <> ": " <> errorMessage err + Right out -> + pure out + pure $ + (textMessage M.Tool outTxt) + { M.messageName = Just tName + , M.messageToolId = Just (toolCallId tc) + } + let newHistory = history ++ [respMsg] ++ obsMsgs + go newHistory (maxIter - 1) diff --git a/src/Langchain/Cache/Core.hs b/src/Langchain/Cache/Core.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Cache/Core.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | +Module : Langchain.Cache.Core +Description : LLM response caching layer with in-memory and SQLite backends +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Transparent caching for ChatModel invocations to reduce latency, cost, and API usage. +-} +module Langchain.Cache.Core + ( CacheBackend (..) + , InMemoryCache (..) + , newInMemoryCache + , SQLiteCache (..) + , newSQLiteCache + , CachedModel (..) + , CacheableChatModel (..) + , withCaching + , computeCacheKey + ) +where + +import Control.Concurrent.STM +import Control.Exception (SomeException, try) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (ToJSON, Value, decode, encode, object, (.=)) +import qualified Data.ByteString.Lazy as LBS +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as TS +import qualified Data.Text.Encoding as TE +import Database.SQLite.Simple +import Langchain.Core.Model + ( ChatModel (..) + , Message (..) + ) +import Langchain.Provider.Gemini (Gemini (..)) +import Langchain.Provider.Ollama (ModelName (..), Ollama (..)) +import Langchain.Provider.OpenAI (OpenAI (..)) +import Langchain.Tool.Binding (ToolBinder (..)) +import qualified Ollama.API.Chat as OllamaChat +import Ollama.Client (OllamaClient (..)) +import Ollama.Client.Config (OllamaClientConfig (..)) + +-- | Effect-polymorphic cache backend typeclass +class CacheBackend cb where + getCache :: (MonadIO m) => cb -> Text -> m (Maybe Message) + putCache :: (MonadIO m) => cb -> Text -> Message -> m () + clearCache :: (MonadIO m) => cb -> m () + +-- | Thread-safe in-memory cache backed by STM TVar +newtype InMemoryCache = InMemoryCache + { memCacheVar :: TVar (Map Text Message) + } + +-- | Construct a new InMemoryCache +newInMemoryCache :: (MonadIO m) => m InMemoryCache +newInMemoryCache = liftIO $ do + var <- newTVarIO Map.empty + pure $ InMemoryCache var + +instance CacheBackend InMemoryCache where + getCache InMemoryCache {..} key = liftIO $ do + m <- readTVarIO memCacheVar + pure $ Map.lookup key m + + putCache InMemoryCache {..} key msg = liftIO $ do + atomically $ modifyTVar' memCacheVar (Map.insert key msg) + + clearCache InMemoryCache {..} = liftIO $ do + atomically $ writeTVar memCacheVar Map.empty + +-- | Persistent SQLite cache backend +newtype SQLiteCache = SQLiteCache + { sqliteCacheDbPath :: FilePath + } + +-- | Construct a new SQLiteCache and create cache table +newSQLiteCache :: (MonadIO m) => FilePath -> m SQLiteCache +newSQLiteCache dbPath = liftIO $ do + _ <- + ( try $ withConnection dbPath $ \conn -> do + execute_ + conn + "CREATE TABLE IF NOT EXISTS langchain_cache (\ + \ cache_key TEXT PRIMARY KEY,\ + \ response_json TEXT NOT NULL,\ + \ created_at DATETIME DEFAULT CURRENT_TIMESTAMP\ + \);" + ) :: + IO (Either SomeException ()) + pure $ SQLiteCache dbPath + +instance CacheBackend SQLiteCache where + getCache SQLiteCache {..} key = liftIO $ do + rowsRes <- + ( try $ withConnection sqliteCacheDbPath $ \conn -> do + query conn "SELECT response_json FROM langchain_cache WHERE cache_key = ?" (Only (TS.unpack key)) :: + IO [Only String] + ) :: + IO (Either SomeException [Only String]) + case rowsRes of + Right [Only jsonStr] -> + let bs = LBS.fromStrict (TE.encodeUtf8 (TS.pack jsonStr)) + in pure (decode bs) + _ -> pure Nothing + + putCache SQLiteCache {..} key msg = liftIO $ do + let jsonStr = TS.unpack $ TE.decodeUtf8 $ LBS.toStrict (encode msg) + _ <- + ( try $ withConnection sqliteCacheDbPath $ \conn -> do + execute + conn + "INSERT OR REPLACE INTO langchain_cache (cache_key, response_json) VALUES (?, ?)" + (TS.unpack key, jsonStr) + ) :: + IO (Either SomeException ()) + pure () + + clearCache SQLiteCache {..} = liftIO $ do + _ <- + ( try $ withConnection sqliteCacheDbPath $ \conn -> do + execute_ conn "DELETE FROM langchain_cache;" + ) :: + IO (Either SomeException ()) + pure () + +-- | ChatModel wrapper that provides transparent response caching +data CachedModel model cache = CachedModel + { underlyingModel :: model + , modelCache :: cache + } + +{- | Wrap a cacheable chat model with a cache backend. + +The wrapped model uses the provider-specific identity supplied by +'CacheableChatModel' when looking up responses. +-} +withCaching :: model -> cache -> CachedModel model cache +withCaching = CachedModel + +-- | Encode a value as JSON text suitable for a cache key. +toJsonText :: (ToJSON a) => a -> Text +toJsonText = TE.decodeUtf8 . LBS.toStrict . encode + +{- | Provider-specific data that distinguishes cacheable model invocations. + +Implementations should include every model property and effective invocation +parameter that can affect a response, but must not include credentials. +-} +class (ChatModel model) => CacheableChatModel model where + -- | Return the JSON identity used to distinguish this model's cache entries. + cacheModelIdentity :: model -> Maybe (ModelConfig model) -> Value + +instance CacheableChatModel OpenAI where + cacheModelIdentity OpenAI {..} _ = + object + [ "provider" .= ("openai" :: Text) + , "model" .= model + , "baseUrl" .= baseUrl + , "temperature" .= temperature + ] + +instance CacheableChatModel Ollama where + cacheModelIdentity o cfg = + let effectiveOptions = cfg >>= OllamaChat.chatOptions + effectiveKeepAlive = cfg >>= OllamaChat.chatKeepAlive + effectiveModel = case cfg of + Just r -> + let m = unModelName (OllamaChat.chatModel r) + in if TS.null m then ollamaModelName o else m + Nothing -> ollamaModelName o + in object + [ "provider" .= ("ollama" :: Text) + , "baseUrl" .= configBaseUrl (clientConfig (client o)) + , "model" .= effectiveModel + , "config" + .= object + [ "tools" .= (OllamaChat.chatTools <$> cfg) + , "format" .= (OllamaChat.chatFormat <$> cfg) + , "options" .= effectiveOptions + , "keep_alive" .= effectiveKeepAlive + , "think" .= (OllamaChat.chatThink <$> cfg) + ] + ] + +instance CacheableChatModel Gemini where + cacheModelIdentity (Gemini _ modelName baseUrl) config + | effectiveBaseUrl == defaultGeminiBaseUrl = defaultIdentity + | otherwise = + object $ + [ "provider" .= ("gemini" :: Text) + , "model" .= modelName + , "baseUrl" .= effectiveBaseUrl + ] + <> maybe [] (pure . ("config" .=)) config + where + effectiveBaseUrl = TS.dropWhileEnd (== '/') $ fromMaybe "" baseUrl + defaultGeminiBaseUrl = "https://generativelanguage.googleapis.com" + defaultIdentity = + object $ + [ "provider" .= ("gemini" :: Text) + , "model" .= modelName + ] + <> maybe [] (pure . ("config" .=)) config + +{- | Compute a canonical cache key from a model identity and complete input messages. + +The key includes all fields of each 'Message', so multi-modal content and +tool calls cannot collide with text-only requests. +-} +computeCacheKey :: + (CacheableChatModel model) => model -> Maybe (ModelConfig model) -> [Message] -> Text +computeCacheKey model cfg msgs = + toJsonText $ + object + [ "model" .= cacheModelIdentity model cfg + , "messages" .= msgs + ] + +instance (CacheableChatModel model, CacheBackend cache) => ChatModel (CachedModel model cache) where + type ModelConfig (CachedModel model cache) = ModelConfig model + + invoke CachedModel {..} msgs mbCfg = do + let key = computeCacheKey underlyingModel mbCfg msgs + mbCached <- getCache modelCache key + case mbCached of + Just cachedMsg -> pure cachedMsg + Nothing -> do + freshMsg <- invoke underlyingModel msgs mbCfg + putCache modelCache key freshMsg + pure freshMsg + + stream CachedModel {..} = + stream underlyingModel + +-- | Delegate tool binding to the underlying model +instance + (CacheableChatModel model, CacheBackend cache, ToolBinder model m) => + ToolBinder (CachedModel model cache) m + where + bindToolsConfig = bindToolsConfig @model diff --git a/src/Langchain/Callback.hs b/src/Langchain/Callback.hs deleted file mode 100644 --- a/src/Langchain/Callback.hs +++ /dev/null @@ -1,87 +0,0 @@ -{- | -Module: Langchain.Callback -Copyright: (c) 2025 Tushar Adhatrao -License: MIT -Maintainer: Tushar Adhatrao -Stability: experimental - -This module provides a callback system for Langchain's language model operations. -Callbacks allow users to perform actions at different stages of an LLM operation, -such as when it starts, completes, or encounters an error. This is useful for -logging, monitoring, or integrating with external systems. - -The callback system is inspired by the Langchain Python library's callback -functionality: [Langchain Callbacks](https://python.langchain.com/docs/concepts/callbacks/). - -== Examples - -See the documentation for 'stdOutCallback' for a basic example, or check the -examples for 'generate', 'chat', and 'stream' in the 'Langchain.LLM.Ollama' module -for practical usage in LLM operations. --} -module Langchain.Callback - ( -- * Event Types - Event (..) - - -- * Callback Interface - , Callback - - -- * Standard Implementations - , stdOutCallback - ) where - -{- | Represents different events that can occur during a language model operation. -These events can be used to trigger callbacks at various stages. --} -data Event - = -- | Indicates the start of an LLM operation, such as generating text or chatting. - LLMStart - | -- | Indicates the successful completion of an LLM operation. - LLMEnd - | -- | Indicates an error occurred during the LLM operation, with the error message. - LLMError String - deriving (Show, Eq) - -{- | A callback is a function that takes an 'Event' and performs some IO action. -This allows users to react to different stages of LLM operations, such as logging -or updating a UI. - -=== Examples - -To create a custom callback that logs events to a file: - -@ -import System.IO -myCallback :: Callback -myCallback event = do - handle <- openFile "llm_log.txt" AppendMode - case event of - LLMStart -> hPutStrLn handle "LLM operation started" - LLMEnd -> hPutStrLn handle "LLM operation completed" - LLMError err -> hPutStrLn handle $ "LLM error: " ++ err - hClose handle -@ --} -type Callback = Event -> IO () - -{- | A standard callback that prints event messages to the standard output. -This is useful for simple debugging or monitoring of LLM operations. - -=== Examples - -Using 'stdOutCallback' in an LLM operation: - -@ -let callbacks = [stdOutCallback] -result <- generate (Ollama "llama3.2:latest" callbacks) "What is 2+2?" Nothing --- Output will include: --- Model operation started --- Model completed with --- (depending on success or error) -@ --} -stdOutCallback :: Callback -stdOutCallback event = case event of - LLMStart -> putStrLn "Model operation started" - LLMEnd -> putStrLn "Model completed with" - LLMError err -> putStrLn $ "Error occurred: " ++ err diff --git a/src/Langchain/Callback/Manager.hs b/src/Langchain/Callback/Manager.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Callback/Manager.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.Callback.Manager +Description : Typed event-driven callback system with synchronous and asynchronous dispatch +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Provides typed callback lifecycle events across models, tools, chains, and state graphs, +with support for filtering and non-blocking asynchronous event dispatch. +-} +module Langchain.Callback.Manager + ( CallbackEvent (..) + , CallbackHandler (..) + , CallbackManager (..) + , newCallbackManager + , registerHandler + , dispatchEvent + , dispatchEventAsync + , newLoggingCallbackHandler + , getCallbackLogs + ) where + +import Control.Concurrent.Async (async) +import Control.Concurrent.STM +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (FromJSON, ToJSON, Value) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime) +import GHC.Generics (Generic) + +-- | Comprehensive lifecycle events emitted across Langchain components +data CallbackEvent + = OnLLMStart !Text ![Text] !UTCTime -- Model name, Prompt inputs, Timestamp + | OnLLMEnd !Text !Text !Int !UTCTime -- Model name, Output text, Latency micros, Timestamp + | OnToolStart !Text !Value !UTCTime -- Tool name, Arguments, Timestamp + | OnToolEnd !Text !Text !Int !UTCTime -- Tool name, Output text, Latency micros, Timestamp + | OnRetrieverStart !Text !Text !UTCTime -- Retriever name, Query, Timestamp + | OnRetrieverEnd !Text ![Text] !Int !UTCTime -- Retriever name, Retrieved snippets, Latency micros, Timestamp + | OnChainStart !Text !Text !UTCTime -- Chain name, Input, Timestamp + | OnChainEnd !Text !Text !Int !UTCTime -- Chain name, Output, Latency micros, Timestamp + | OnGraphNodeStart !Text !Text !UTCTime -- NodeId, State summary, Timestamp + | OnGraphNodeEnd !Text !Text !Int !UTCTime -- NodeId, Next node/state summary, Latency micros, Timestamp + | OnError !Text !Text !UTCTime -- Component name, Error message, Timestamp + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | Handler for processing emitted callback events +data CallbackHandler = CallbackHandler + { handlerName :: !Text + , handleEvent :: CallbackEvent -> IO () + } + +-- | Thread-safe CallbackManager backed by STM TVar +newtype CallbackManager = CallbackManager + { handlersVar :: TVar [CallbackHandler] + } + +-- | Construct an empty CallbackManager +newCallbackManager :: MonadIO m => m CallbackManager +newCallbackManager = liftIO $ do + var <- newTVarIO [] + pure $ CallbackManager var + +-- | Register a new callback handler +registerHandler :: MonadIO m => CallbackManager -> CallbackHandler -> m () +registerHandler CallbackManager {..} handler = liftIO $ do + atomically $ modifyTVar' handlersVar (\handlers -> handlers ++ [handler]) + +-- | Dispatch an event synchronously to all registered handlers +dispatchEvent :: MonadIO m => CallbackManager -> CallbackEvent -> m () +dispatchEvent CallbackManager {..} event = liftIO $ do + handlers <- readTVarIO handlersVar + mapM_ (`handleEvent` event) handlers + +-- | Dispatch an event asynchronously in background threads without blocking +dispatchEventAsync :: MonadIO m => CallbackManager -> CallbackEvent -> m () +dispatchEventAsync CallbackManager {..} event = liftIO $ do + handlers <- readTVarIO handlersVar + mapM_ (\h -> async (handleEvent h event)) handlers + +-- | Create a simple callback handler that logs event descriptions into an STM TVar +newLoggingCallbackHandler :: MonadIO m => Text -> m (CallbackHandler, TVar [Text]) +newLoggingCallbackHandler name = liftIO $ do + logsVar <- newTVarIO [] + let handler = + CallbackHandler + { handlerName = name + , handleEvent = \event -> atomically $ modifyTVar' logsVar (\logs -> logs ++ [T.pack (show event)]) + } + pure (handler, logsVar) + +-- | Read all logs accumulated by a logging callback handler +getCallbackLogs :: MonadIO m => TVar [Text] -> m [Text] +getCallbackLogs = liftIO . readTVarIO diff --git a/src/Langchain/Chain/MapReduce.hs b/src/Langchain/Chain/MapReduce.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Chain/MapReduce.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.Chain.MapReduce +Description : Map-Reduce document summarization and synthesis chain +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Applies a map LLM prompt individually over each document, then combines and synthesizes results +using a reduce LLM prompt. +-} +module Langchain.Chain.MapReduce + ( MapReduceChain (..) + , newMapReduceChain + , defaultMapPrompt + , defaultReducePrompt + , runMapReduceChain + ) where + +import Control.Monad (forM) +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.IO.Class (MonadIO) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +import Langchain.Core.Error (LangchainError) +import Langchain.Core.Model + ( ChatModel (..) + , Message + , extractMessageText + , userMessage + ) +import Langchain.DocumentLoader.Core (Document (..)) +import Langchain.PromptTemplate.Prompt (PromptTemplate, fromTemplate, renderPrompt) + +-- | Map-Reduce chain configuration +data MapReduceChain model = MapReduceChain + { mapReduceModel :: model + , mapPromptTemplate :: PromptTemplate + , reducePromptTemplate :: PromptTemplate + , mapDocVar :: Text + , reduceDocVar :: Text + } + +-- | Default map prompt for individual document summarization +defaultMapPrompt :: PromptTemplate +defaultMapPrompt = + fromTemplate + "Summarize the key information in the following document concisely:\n\n{document}\n\nSummary:" + +-- | Default reduce prompt for synthesizing all document summaries +defaultReducePrompt :: PromptTemplate +defaultReducePrompt = + fromTemplate + "Combine and synthesize the following summaries into a comprehensive final response:\n\n{summaries}\n\nFinal Synthesis:" + +-- | Construct a new MapReduceChain +newMapReduceChain :: model -> MapReduceChain model +newMapReduceChain m = + MapReduceChain + { mapReduceModel = m + , mapPromptTemplate = defaultMapPrompt + , reducePromptTemplate = defaultReducePrompt + , mapDocVar = "document" + , reduceDocVar = "summaries" + } + +-- | Execute MapReduceChain across documents +runMapReduceChain :: + (ChatModel model, MonadIO m, MonadError LangchainError m) => + MapReduceChain model -> + [Document] -> + Map Text Text -> + m Message +runMapReduceChain MapReduceChain {..} docs baseVars = do + -- Phase 1: Map over each document + summaries <- forM docs $ \doc -> do + let docTxt = TL.toStrict (pageContent doc) + vars = Map.insert mapDocVar docTxt baseVars + rendered <- case renderPrompt mapPromptTemplate vars of + Left err -> throwError err + Right p -> pure p + resp <- invoke mapReduceModel [userMessage rendered] Nothing + pure $ extractMessageText resp + + -- Phase 2: Reduce summaries into final synthesis + let combinedSummaries = T.intercalate "\n\n---\n\n" summaries + reduceVars = Map.insert reduceDocVar combinedSummaries baseVars + renderedReduce <- case renderPrompt reducePromptTemplate reduceVars of + Left err -> throwError err + Right p -> pure p + invoke mapReduceModel [userMessage renderedReduce] Nothing diff --git a/src/Langchain/Chain/RetrievalQA.hs b/src/Langchain/Chain/RetrievalQA.hs --- a/src/Langchain/Chain/RetrievalQA.hs +++ b/src/Langchain/Chain/RetrievalQA.hs @@ -1,79 +1,75 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} {- | Module : Langchain.Chain.RetrievalQA -Description : Chain for question-answering against an index. -Copyright : (c) 2025 Tushar Adhatrao +Description : Effect-polymorphic RetrievalQA chain +Copyright : (c) 2025-2026 Tushar Adhatrao License : MIT Maintainer : Tushar Adhatrao +Stability : experimental -Haskell implementation of RetrievalQA. +RetrievalQA chain combining retriever search, context assembly, prompt rendering, +and ChatModel question answering. -} module Langchain.Chain.RetrievalQA ( RetrievalQA (..) + , newRetrievalQA , defaultQAPrompt + , runRetrievalQA ) where -import qualified Data.List.NonEmpty as NE +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.IO.Class (MonadIO) import Data.Map.Strict (fromList) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL + +import Langchain.Core.Error (LangchainError) +import Langchain.Core.Model + ( ChatModel (..) + , Message + , systemMessage + , userMessage + ) import Langchain.DocumentLoader.Core (Document (..)) -import Langchain.LLM.Core -import Langchain.PromptTemplate (PromptTemplate (..), renderPrompt) -import Langchain.Retriever.Core (Retriever (_get_relevant_documents)) -import Langchain.Runnable.Core (Runnable (..)) +import Langchain.PromptTemplate.Prompt (PromptTemplate, fromTemplate, renderPrompt) +import Langchain.Retriever.Core (Retriever (..)) --- | QA Chain that combines retrieval and LLM response generation. -data RetrievalQA llm retriever = RetrievalQA - { llm :: llm - , llmParams :: Maybe (LLMParams llm) +-- | QA Chain configuration combining retrieval and LLM response generation. +data RetrievalQA model retriever = RetrievalQA + { model :: model , retriever :: retriever , prompt :: PromptTemplate } --- | Creates a default QA prompt with context and question placeholders. +-- | Construct a new RetrievalQA chain with default prompt +newRetrievalQA :: model -> retriever -> RetrievalQA model retriever +newRetrievalQA m r = RetrievalQA m r defaultQAPrompt + +-- | Default QA prompt template defaultQAPrompt :: PromptTemplate defaultQAPrompt = - PromptTemplate - ( "Use the given context to answer the question. " - <> "If you don't know the answer, say you don't know. " - <> "Use three sentence maximum and keep the answer concise. " - <> "Context: {context}" + fromTemplate + ( "Use the following pieces of context to answer the question at the end.\n" + <> "If you don't know the answer, just say that you don't know, don't try to make up an answer.\n\n" + <> "Context:\n{context}" ) --- | Make RetrievalQA an instance of Runnable to allow composition. -instance (LLM llm, Retriever retriever) => Runnable (RetrievalQA llm retriever) where - type RunnableInput (RetrievalQA llm retriever) = Text - type RunnableOutput (RetrievalQA llm retriever) = Message - - invoke RetrievalQA {..} question = do - -- Retrieve relevant documents - docResult <- _get_relevant_documents retriever question - case docResult of - Left err -> return $ Left err - Right docs -> do - let context = T.intercalate "\n\n" $ map (\(Document c _) -> TL.toStrict c) docs - let vars = [("context", context)] - - -- Render prompt with context and question - renderedPrompt <- case renderPrompt prompt (fromList vars) of - Left e -> return $ Left e - Right r -> return $ Right r - - case renderedPrompt of - Left e -> return $ Left e - Right finalPrompt -> do - let chatConvo = - NE.fromList - [ Message System finalPrompt defaultMessageData - , Message User question defaultMessageData - ] - -- Get LLM response - llmResponse <- chat llm chatConvo llmParams - case llmResponse of - Left e -> return $ Left e - Right answer -> return $ Right answer +-- | Execute RetrievalQA chain on a user question +runRetrievalQA :: + (ChatModel model, Retriever retriever, MonadIO m, MonadError LangchainError m) => + RetrievalQA model retriever -> + Text -> + m Message +runRetrievalQA RetrievalQA {..} question = do + docs <- getRelevantDocuments retriever question + let contextText = T.intercalate "\n\n" $ map (TL.toStrict . pageContent) docs + vars = fromList [("context", contextText)] + renderedPrompt <- case renderPrompt prompt vars of + Left err -> throwError err + Right p -> pure p + let conversation = [systemMessage renderedPrompt, userMessage question] + invoke model conversation Nothing diff --git a/src/Langchain/DocumentLoader/Core.hs b/src/Langchain/DocumentLoader/Core.hs --- a/src/Langchain/DocumentLoader/Core.hs +++ b/src/Langchain/DocumentLoader/Core.hs @@ -1,147 +1,57 @@ +{-# LANGUAGE FlexibleContexts #-} + {- | Module : Langchain.DocumentLoader.Core Description : Core document loading functionality for LangChain Haskell -Copyright : (c) 2025 Tushar Adhatrao +Copyright : (c) 2025-2026 Tushar Adhatrao License : MIT Maintainer : Tushar Adhatrao Stability : experimental -Implementation of LangChain's document loading abstraction, providing: - -- Document representation with content and metadata -- Typeclass for loading/splitting documents from various sources -- Integration with text splitting capabilities - -For more information on document loader in the original Langchain library, see: -https://python.langchain.com/docs/concepts/document_loaders/ - -Example usage: - -@ --- Create a document -doc :: Document -doc = Document "Sample content" (fromList [("source", String "example.txt")]) - --- Hypothetical file loader instance -data FileLoader = FileLoader FilePath - -instance BaseLoader FileLoader where - load (FileLoader path) = do - content <- readFile path - return $ Right [Document content (fromList [("source", String (T.pack path))])] -@ - -Test case patterns: - ->>> mempty :: Document -Document {pageContent = "", metadata = fromList []} - ->>> doc1 = Document "Hello" (fromList [("a", Number 1)]) ->>> doc2 = Document " World" (fromList [("b", Bool True)]) ->>> doc1 <> doc2 -Document {pageContent = "Hello World", metadata = fromList [("a", Number 1), ("b", Bool True)]} +Implementation of LangChain's document loading abstraction. -} module Langchain.DocumentLoader.Core - ( -- * Document Representation - Document (..) - - -- * Loading Interface + ( Document (..) , BaseLoader (..) ) where -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Aeson +import Control.Monad.Except (MonadError) +import Control.Monad.IO.Class (MonadIO) +import Data.Aeson (Value) import Data.Map (Map, empty) +import qualified Data.Text as TS import Data.Text.Lazy (Text) -import Langchain.Error (LangchainResult) -{- | Document container with content and metadata. -Used for storing loaded data and associated metadata like source URLs or page numbers. - -Example: +import Langchain.Core.Error (LangchainError) ->>> Document "Hello World" (fromList [("source", String "example.txt")]) -Document {pageContent = "Hello World", metadata = fromList [("source",String "example.txt")]} --} +-- | Document container with content and metadata data Document = Document { pageContent :: Text -- ^ The text content of the document - , metadata :: Map Text Value + , metadata :: Map TS.Text Value -- ^ Additional metadata (e.g., source, page number) } deriving (Show, Eq) -{- | Semigroup instance combines both content and metadata - ->>> let doc1 = Document "A" (fromList [("x", Number 1)]) ->>> let doc2 = Document "B" (fromList [("y", Bool True)]) ->>> doc1 <> doc2 -Document {pageContent = "AB", metadata = fromList [("x", Number 1), ("y", Bool True)]} --} instance Semigroup Document where doc1 <> doc2 = Document (pageContent doc1 <> pageContent doc2) (metadata doc1 <> metadata doc2) -{- | Monoid instance provides empty document: - ->>> mempty :: Document -Document {pageContent = "", metadata = fromList []} --} instance Monoid Document where mempty = Document mempty empty -{- | Typeclass for document loading implementations. -Implementations should define how to: - -1. Load full documents with 'load' -2. Load and split content with 'loadAndSplit' - -Example instance for text files: - -@ -instance BaseLoader FilePath where - load path = do - content <- readFile path - return $ Right [Document content (fromList [("source", String (T.pack path))])] - - loadAndSplit path = do - content <- readFile path - return $ Right (splitText defaultCharacterSplitterOps content) -@ --} +-- | Effect-polymorphic BaseLoader typeclass class BaseLoader loader where - -- | Load all documents from the source. - load :: loader -> IO (LangchainResult [Document]) - - loadM :: MonadIO m => loader -> m (LangchainResult [Document]) - loadM loader = liftIO $ load loader - - -- | Load all the document and split them using recursiveCharacterSpliter - loadAndSplit :: loader -> IO (LangchainResult [Text]) - - loadAndSplitM :: MonadIO m => loader -> m (LangchainResult [Text]) - loadAndSplitM loader = liftIO $ loadAndSplit loader - -{- $examples -Key test case demonstrations: - -1. Metadata merging - >>> let doc1 = Document "A" (fromList [("x", Number 1)]) - >>> let doc2 = Document "B" (fromList [("y", Bool True)]) - >>> metadata (doc1 <> doc2) - fromList [("x", Number 1), ("y", Bool True)] - -2. File loading error handling - >>> load (FileLoader "non-existent.txt") - Left "File not found: non-existent.txt" - -3. Content splitting - >>> loadAndSplit (FileLoader "test.txt") - Right ["Paragraph 1", "Paragraph 2"] --} + -- | Load all documents from the source + load :: + (MonadIO m, MonadError LangchainError m) => + loader -> + m [Document] --- TODO: Implement lazy versions of Document and load. --- Lazily load documents from the source. --- lazyLoad :: m -> IO (Either String [Document]) + -- | Load all documents and split their content + loadAndSplit :: + (MonadIO m, MonadError LangchainError m) => + loader -> + m [Text] diff --git a/src/Langchain/DocumentLoader/Csv.hs b/src/Langchain/DocumentLoader/Csv.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/DocumentLoader/Csv.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Langchain.DocumentLoader.Csv +Description : CSV file document loader +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Loads CSV files as LangChain Documents where each row produces a Document. +-} +module Langchain.DocumentLoader.Csv + ( CsvLoader (..) + , defaultCsvLoader + , parseCsvRows + ) where + +import Control.Exception (try) +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value (..)) +import qualified Data.Map.Strict as Map +import qualified Data.Text as TS +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.IO as TLIO + +import Langchain.Core.Error (documentLoaderError) +import Langchain.DocumentLoader.Core (BaseLoader (..), Document (..)) +import Langchain.TextSplitter.Character (defaultCharacterSplitterOps, splitText) + +-- | Configuration options for CSV loader +data CsvLoader = CsvLoader + { csvFilePath :: FilePath + , csvDelimiter :: Char + , csvContentColumns :: Maybe [TS.Text] + -- ^ Optional list of columns to include in pageContent. If Nothing, all columns are concatenated. + , csvSplitter :: Maybe (Text -> [Text]) + } + +-- | Default CSV loader configuration +defaultCsvLoader :: FilePath -> CsvLoader +defaultCsvLoader path = + CsvLoader + { csvFilePath = path + , csvDelimiter = ',' + , csvContentColumns = Nothing + , csvSplitter = Nothing + } + +instance BaseLoader CsvLoader where + load loader = do + contentRes <- liftIO $ try $ TLIO.readFile (csvFilePath loader) + content <- case contentRes of + Left err -> + throwError $ + documentLoaderError + (TS.pack $ "Failed to read CSV file: " ++ show (err :: IOError)) + (Just "CsvLoader") + Nothing + Right c -> pure c + + let rows = parseCsvRows (csvDelimiter loader) content + case rows of + [] -> pure [] + (headers : dataRows) -> do + let headerTexts = map (TS.pack . TL.unpack . TL.strip) headers + docs = + [ makeDocument headerTexts (map TL.strip row) (csvContentColumns loader) (csvFilePath loader) idx + | (idx, row) <- zip [1 ..] dataRows + , not (null row) && not (all TL.null row) + ] + pure docs + + loadAndSplit loader = do + docs <- load loader + let splitter = case csvSplitter loader of + Just s -> s + Nothing -> splitText defaultCharacterSplitterOps + pure $ concatMap (splitter . pageContent) docs + +makeDocument :: [TS.Text] -> [Text] -> Maybe [TS.Text] -> FilePath -> Int -> Document +makeDocument headers values mbSelectedCols filePath rowIdx = + let pairs = zip headers values + metaMap = + Map.fromList + [ (h, String (TS.pack $ TL.unpack val)) + | (h, val) <- pairs + ] + metaWithSource = + Map.insert "source" (String $ TS.pack filePath) $ + Map.insert "row" (Number $ fromIntegral rowIdx) metaMap + contentLines = case mbSelectedCols of + Just selected -> + [ h <> ": " <> TS.pack (TL.unpack val) + | (h, val) <- pairs + , h `elem` selected + ] + Nothing -> + [ h <> ": " <> TS.pack (TL.unpack val) + | (h, val) <- pairs + ] + content = TL.pack $ TS.unpack $ TS.intercalate "\n" contentLines + in Document content metaWithSource + +-- | Robust CSV line parser supporting quoted cells with commas +parseCsvRows :: Char -> Text -> [[Text]] +parseCsvRows delim text = + let allLines = TL.lines text + in map (parseCsvLine delim) allLines + +parseCsvLine :: Char -> Text -> [Text] +parseCsvLine delim line = go False [] "" (TL.unpack line) + where + go :: Bool -> [Text] -> String -> String -> [Text] + go _ acc cur [] = reverse (TL.pack (reverse cur) : acc) + go inQuote acc cur ('"' : cs) = + case cs of + ('"' : rest) -> go inQuote acc ('"' : cur) rest + _ -> go (not inQuote) acc cur cs + go inQuote acc cur (c : cs) + | c == delim && not inQuote = + go inQuote (TL.pack (reverse cur) : acc) "" cs + | otherwise = + go inQuote acc (c : cur) cs diff --git a/src/Langchain/DocumentLoader/DirectoryLoader.hs b/src/Langchain/DocumentLoader/DirectoryLoader.hs --- a/src/Langchain/DocumentLoader/DirectoryLoader.hs +++ b/src/Langchain/DocumentLoader/DirectoryLoader.hs @@ -1,36 +1,36 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {- | Module : Langchain.DocumentLoader.DirectoryLoader Description : Directory loading implementation for LangChain Haskell -Copyright : (c) 2025 Tushar Adhatrao +Copyright : (c) 2025-2026 Tushar Adhatrao License : MIT Maintainer : Tushar Adhatrao Stability : experimental -DirectoryLoader document loader implements functionality for reading files from disk into Documents +DirectoryLoader document loader reads files from disk into Documents. -} module Langchain.DocumentLoader.DirectoryLoader - ( -- * Directory loader - DirectoryLoader (..) + ( DirectoryLoader (..) , DirectoryLoaderOptions (..) - - -- * Default functions , defaultDirectoryLoaderOptions ) where import Control.Concurrent.Async (mapConcurrently) -import Control.Monad (filterM) +import Control.Monad (filterM, forM) +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (liftIO) import Data.Maybe (listToMaybe) import qualified Data.Text as T +import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) +import System.FilePath (takeExtension, takeFileName, ()) + +import Langchain.Core.Error (documentLoaderError) import Langchain.DocumentLoader.Core import Langchain.DocumentLoader.FileLoader (FileLoader (FileLoader)) -import Langchain.DocumentLoader.PdfLoader (PdfLoader (PdfLoader)) -import Langchain.Error (LangchainError, llmError) import Langchain.TextSplitter.Character -import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) -import System.FilePath (takeExtension, takeFileName, ()) -- | Options for directory loading behavior data DirectoryLoaderOptions = DirectoryLoaderOptions @@ -50,18 +50,12 @@ defaultDirectoryLoaderOptions = DirectoryLoaderOptions { recursiveDepth = Nothing - , extensions = [] -- Empty list means all files + , extensions = [] , excludeHidden = True , useMultithreading = False } -{- | Directory loader configuration -Specifies the path to load documents from. - -Example: - ->>> DirectoryLoader "langchain-hs/src" defaultDirectoryLoaderOptions --} +-- | Directory loader configuration data DirectoryLoader = DirectoryLoader { dirPath :: FilePath , directoryLoaderOptions :: DirectoryLoaderOptions @@ -81,7 +75,6 @@ -- | Get all files in a directory, with controlled recursion getFilesInDirectory :: DirectoryLoaderOptions -> Int -> FilePath -> IO [FilePath] getFilesInDirectory opts currentDepth dir = do - -- Check if we've reached max depth (if specified) let canRecurse = case recursiveDepth opts of Nothing -> True Just maxD -> currentDepth < maxD @@ -89,22 +82,18 @@ entries <- listDirectory dir let fullPaths = map (dir ) entries - -- Find all files in current directory files <- filterM doesFileExist fullPaths let filteredFiles = filter (shouldIncludeFile opts) files - -- If we can recurse deeper and recursion is enabled, process subdirectories subFiles <- if canRecurse then do subdirs <- filterM doesDirectoryExist fullPaths - -- Skip hidden directories if excludeHidden is set let visibleSubdirs = if excludeHidden opts then filter (\d -> not (null d) && listToMaybe d /= Just '.') subdirs else subdirs - -- Process subdirectories (potentially in parallel) if useMultithreading opts && not (null visibleSubdirs) then concat @@ -112,63 +101,25 @@ (getFilesInDirectory opts (currentDepth + 1)) visibleSubdirs else concat <$> mapM (getFilesInDirectory opts (currentDepth + 1)) visibleSubdirs - else return [] - - return $ filteredFiles ++ subFiles + else pure [] -loadFileToDocument :: FilePath -> IO (Either LangchainError [Document]) -loadFileToDocument path = do - exists <- doesFileExist path - if not exists - then - return $ - Left - ( llmError - (T.pack $ "File does not exist: " ++ path) - Nothing - Nothing - ) - else do - -- if file is pdf then read it using PdfLoader else use fileLoader - if takeExtension path == ".pdf" - then - load (PdfLoader path) - else - load (FileLoader path) + pure $ filteredFiles ++ subFiles instance BaseLoader DirectoryLoader where load DirectoryLoader {..} = do - exists <- doesDirectoryExist dirPath + exists <- liftIO $ doesDirectoryExist dirPath if exists then do - filePaths <- getFilesInDirectory directoryLoaderOptions 0 dirPath - -- Process files (using multithreading if enabled) - docs <- - if useMultithreading directoryLoaderOptions && not (null filePaths) - then mapConcurrently loadFileToDocument filePaths - else mapM loadFileToDocument filePaths - -- Separate successes and failures - let (errors, documents) = foldr separateResults ([], []) docs - - -- Return documents or combined error message - case listToMaybe errors of - Nothing -> return $ Right documents - Just err -> return $ Left err + filePaths <- liftIO $ getFilesInDirectory directoryLoaderOptions 0 dirPath + fmap concat $ forM filePaths $ \path -> + load (FileLoader path) else - return $ - Left $ - llmError (T.pack $ "Directory does not exist: " ++ dirPath) Nothing Nothing - where - separateResults (Left err) (errs, docs) = (err : errs, docs) - separateResults (Right doc) (errs, docs) = (errs, doc <> docs) + throwError $ + documentLoaderError + (T.pack $ "Directory does not exist: " ++ dirPath) + (Just "DirectoryLoader") + (Just $ T.pack dirPath) loadAndSplit dirLoader = do - eRes <- load dirLoader - case eRes of - Left e -> pure $ Left e - Right documents -> - pure $ - Right $ - splitText - defaultCharacterSplitterOps - (pageContent $ mconcat documents) + documents <- load dirLoader + pure $ splitText defaultCharacterSplitterOps (pageContent $ mconcat documents) diff --git a/src/Langchain/DocumentLoader/FileLoader.hs b/src/Langchain/DocumentLoader/FileLoader.hs --- a/src/Langchain/DocumentLoader/FileLoader.hs +++ b/src/Langchain/DocumentLoader/FileLoader.hs @@ -1,126 +1,76 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Langchain.DocumentLoader.FileLoader Description : File loading implementation for LangChain Haskell -Copyright : (c) 2025 Tushar Adhatrao +Copyright : (c) 2025-2026 Tushar Adhatrao License : MIT Maintainer : Tushar Adhatrao Stability : experimental -File-based document loader implementation following LangChain's document loading patterns -Integrates with the core document splitting functionality for processing text files. - -Example usage: - -@ --- Load a document from file -loader = FileLoader "data.txt" -docs <- load loader --- Right [Document {pageContent = "File content", metadata = ...}] - --- Load and split document content -chunks <- loadAndSplit loader --- Right ["First paragraph", "Second paragraph", ...] -@ +File-based document loader implementation following LangChain's document loading patterns. -} module Langchain.DocumentLoader.FileLoader ( FileLoader (..) ) where +import Control.Exception (SomeException, try) +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (liftIO) import Data.Aeson import Data.Map (fromList) import qualified Data.Text as T import qualified Data.Text.Lazy as TL -import Langchain.DocumentLoader.Core -import Langchain.Error (SomeException, llmError, try) -import Langchain.TextSplitter.Character import System.Directory (doesFileExist) -{- | File loader configuration -Specifies the file path to load documents from. - -Example: +import Langchain.Core.Error (documentLoaderError) +import Langchain.DocumentLoader.Core +import Langchain.TextSplitter.Character ->>> FileLoader "docs/example.txt" -FileLoader "docs/example.txt" --} +-- | File loader configuration newtype FileLoader = FileLoader FilePath + deriving (Eq, Show) instance BaseLoader FileLoader where - -- \| Load document with file source metadata - -- - -- Example: - - -- >>> load (FileLoader "test.txt") - -- Right [Document {pageContent = "Test content", metadata = fromList [("source", "test.txt")]}] - -- load (FileLoader path) = do - exists <- doesFileExist path + exists <- liftIO $ doesFileExist path if exists then do - eContent <- try $ readFile path + eContent <- liftIO $ try (readFile path) case eContent of Left err -> - return $ - Left $ - llmError - (T.pack $ "Error reading file: " ++ path ++ show (err :: SomeException)) - Nothing - Nothing + throwError $ + documentLoaderError + (T.pack $ "Error reading file " ++ path ++ ": " ++ show (err :: SomeException)) + (Just "FileLoader") + (Just $ T.pack path) Right content -> do let meta = fromList [("source", String $ T.pack path)] - return $ Right [Document (TL.pack content) meta] + pure [Document (TL.pack content) meta] else - return $ - Left - ( llmError - (T.pack $ "File not found: " ++ path) - Nothing - Nothing - ) - - -- \| Load and split content using default character splitter - -- - -- Example: + throwError $ + documentLoaderError + (T.pack $ "File not found: " ++ path) + (Just "FileLoader") + (Just $ T.pack path) - -- >>> loadAndSplit (FileLoader "split.txt") - -- Right ["Paragraph 1", "Paragraph 2", ...] - -- loadAndSplit (FileLoader path) = do - exists <- doesFileExist path + exists <- liftIO $ doesFileExist path if exists then do - eContent <- try $ readFile path + eContent <- liftIO $ try (readFile path) case eContent of Left err -> - return $ - Left $ - llmError - (T.pack $ "Error reading file: " ++ path ++ show (err :: SomeException)) - Nothing - Nothing - Right content -> return $ Right $ splitText defaultCharacterSplitterOps (TL.pack content) + throwError $ + documentLoaderError + (T.pack $ "Error reading file " ++ path ++ ": " ++ show (err :: SomeException)) + (Just "FileLoader") + (Just $ T.pack path) + Right content -> pure $ splitText defaultCharacterSplitterOps (TL.pack content) else - return $ - Left - ( llmError - (T.pack $ "File not found: " ++ path) - Nothing - Nothing - ) - -{- $examples -Test case patterns: -1. Successful load with metadata - >>> withTestFile "Content" $ \path -> load (FileLoader path) - Right [Document {pageContent = "Content", metadata = ...}] - -2. Error handling for missing files - >>> load (FileLoader "missing.txt") - Left "File not found: missing.txt" - -3. Content splitting with default parameters - >>> withTestFile "A\n\nB\n\nC" $ \path -> loadAndSplit (FileLoader path) - Right ["A", "B", "C"] --} + throwError $ + documentLoaderError + (T.pack $ "File not found: " ++ path) + (Just "FileLoader") + (Just $ T.pack path) diff --git a/src/Langchain/DocumentLoader/PdfLoader.hs b/src/Langchain/DocumentLoader/PdfLoader.hs deleted file mode 100644 --- a/src/Langchain/DocumentLoader/PdfLoader.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{- | -Module : Langchain.DocumentLoader.PdfLoader -Description : A PDF loader that extracts documents from PDF files. -Copyright : (C) 2025 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental - -This module provides a loader for loading PDF files. --} -module Langchain.DocumentLoader.PdfLoader - ( PdfLoader (..) - ) where - -import Data.Aeson -import Data.Map (fromList) -import qualified Data.Text.Lazy as TL -import Langchain.DocumentLoader.Core -import Langchain.Error (llmError) -import Langchain.TextSplitter.Character -import Langchain.Utils (showText) -import Pdf.Document hiding (Document) -import System.Directory (doesFileExist) - --- TODO: Need some error handling for this function - -{- | -An internal function -Reads a PDF file and extracts a list of 'Document's, one per page. - -This function opens the PDF file at the specified 'FilePath' and uses -the Pdf.Document library to extract the text from each page. Each page's -content is wrapped in a 'Document' along with metadata indicating the page number. - -Note: This function currently has minimal error handling. Improvements may be -required to properly handle various PDF parsing errors. - -@param fPath The file path to the PDF file. -@return An IO action yielding a list of 'Document's extracted from the PDF. --} -readPdf :: FilePath -> IO [Document] -readPdf fPath = do - withPdfFile fPath $ \pdf -> do - doc <- document pdf - catalog <- documentCatalog doc - rootNode <- catalogPageNode catalog - count <- pageNodeNKids rootNode - textList <- - sequence - [ pageExtractText - =<< pageNodePageByNum rootNode i - | i <- [0 .. count - 1] - ] - pure $ - zipWith - ( \content pageNum -> - Document - { pageContent = content - , metadata = - fromList - [ ("page number", Number $ fromIntegral pageNum) - ] - } - ) - (map TL.fromStrict textList) - [1 .. count] - -{- | -A loader for PDF files. - -The 'PdfLoader' data type encapsulates a 'FilePath' pointing to a PDF document. -It implements the 'BaseLoader' interface to provide methods for loading and -splitting PDF content. --} -newtype PdfLoader = PdfLoader FilePath - -instance BaseLoader PdfLoader where - -- \| - -- Loads all pages from the PDF file specified by the 'PdfLoader'. - -- - -- This function first checks whether the file exists. If it does, it uses - -- 'readPdf' to extract the content of each page as a separate 'Document'. If - -- the file is not found, an appropriate error message is returned. - -- - -- @param loader A 'PdfLoader' containing the file path to the PDF. - -- @return An IO action yielding either an error message or a list of 'Document's. - -- - load (PdfLoader path) = do - exists <- doesFileExist path - if exists - then do - content <- readPdf path - return $ Right content - else - return $ - Left $ - llmError (showText $ "File not found: " ++ path) Nothing Nothing - - -- \| - -- Loads the raw content of the PDF file and splits it using a character splitter. - -- - -- This method reads the entire pdf as text and applies - -- 'splitText' with default recursive character options to divide the text into chunks. - -- This approach is useful when only a simple text split is required rather than structured - -- page extraction. - -- - -- @param loader A 'PdfLoader' containing the file path to the PDF. - -- @return An IO action yielding either an error message or a list of text chunks. - -- - loadAndSplit (PdfLoader path) = do - exists <- doesFileExist path - if exists - then do - documents <- readPdf path - return $ - Right $ - splitText - defaultCharacterSplitterOps - (pageContent $ mconcat documents) - else - return $ - Left $ - llmError (showText $ "File not found: " ++ path) Nothing Nothing diff --git a/src/Langchain/Embeddings/Core.hs b/src/Langchain/Embeddings/Core.hs --- a/src/Langchain/Embeddings/Core.hs +++ b/src/Langchain/Embeddings/Core.hs @@ -1,100 +1,38 @@ +{-# LANGUAGE FlexibleContexts #-} + {- | Module : Langchain.Embeddings.Core -Description : Embedding model interface for LangChain Haskell -Copyright : (c) 2025 Tushar Adhatrao +Description : Effect-polymorphic embedding model interface +Copyright : (c) 2025-2026 Tushar Adhatrao License : MIT Maintainer : Tushar Adhatrao Stability : experimental -Haskell implementation of LangChain's embedding model abstraction, providing: - -- Document vectorization for semantic search -- Query embedding for similarity comparisons -- Integration with document loading pipelines - -Example usage: - -@ - let oEmbed = defaultOpenAIEmbeddings { apiKey = "api-key" } - let p = PdfLoader "/home/user/Documents/TS/langchain/SOP.pdf" - eDocs <- load p - case eDocs of - Left err -> error err - Right docs -> do - eRes <- embedQuery oEmbed "Hello" - print eRes -@ +Effect-polymorphic Embeddings typeclass. -} module Langchain.Embeddings.Core - ( -- * Embedding Interface - Embeddings (..) + ( Embeddings (..) ) where -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Except (MonadError) +import Control.Monad.IO.Class (MonadIO) import Data.Text (Text) -import Langchain.DocumentLoader.Core -import Langchain.Error (LangchainResult) -{- | Typeclass for embedding models following LangChain's pattern. -Converts text/documents into numerical vectors for machine learning tasks. - -Implementations should handle: - -- Text preprocessing -- API calls to embedding services -- Error handling for failed requests -- Consistent vector dimensionality - -Example instance for a test model: - -@ -data TestEmbeddings = TestEmbeddings +import Langchain.Core.Error (LangchainError) +import Langchain.DocumentLoader.Core (Document) -instance Embeddings TestEmbeddings where - embedDocuments _ _ = return $ Right [[0.1, 0.2, 0.3]] - embedQuery _ _ = return $ Right [0.4, 0.5, 0.6] -@ --} +-- | Effect-polymorphic Embeddings typeclass class Embeddings embed where - {- | Convert documents to embedding vectors - - Example: - - >>> let doc = Document "Hello world" mempty - >>> embedDocuments TestEmbeddings [doc] - Right [[0.1, 0.2, 0.3]] - -} - embedDocuments :: embed -> [Document] -> IO (LangchainResult [[Float]]) - - embedDocumentsM :: MonadIO m => embed -> [Document] -> m (LangchainResult [[Float]]) - embedDocumentsM embeddings docs = liftIO $ embedDocuments embeddings docs - - {- | Convert query text to embedding vector - - Example: - - >>> embedQuery TestEmbeddings "Search query" - Right [0.4, 0.5, 0.6] - -} - embedQuery :: embed -> Text -> IO (LangchainResult [Float]) - - embedQueryM :: MonadIO m => embed -> Text -> m (LangchainResult [Float]) - embedQueryM embeddings query = liftIO $ embedQuery embeddings query - -{- $examples -Test case patterns: - -1. Document embedding - >>> let docs = [Document "Test content" mempty] - >>> embedDocuments TestEmbeddings docs - Right [[0.1, 0.2, 0.3]] - -2. Query embedding - >>> embedQuery TestEmbeddings "Test query" - Right [0.4, 0.5, 0.6] + -- | Convert documents to embedding vectors + embedDocuments :: + (MonadIO m, MonadError LangchainError m) => + embed -> + [Document] -> + m [[Float]] -3. Error handling - >>> -- Simulate failed API call - >>> embedQuery FaultyEmbeddings "Bad request" - Left "API request failed" --} + -- | Convert query text to embedding vector + embedQuery :: + (MonadIO m, MonadError LangchainError m) => + embed -> + Text -> + m [Float] diff --git a/src/Langchain/Embeddings/Gemini.hs b/src/Langchain/Embeddings/Gemini.hs deleted file mode 100644 --- a/src/Langchain/Embeddings/Gemini.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -{- | -Module : Langchain.Embeddings.Gemini -Description : Gemini integration for text embeddings in LangChain Haskell -Copyright : (c) 2025 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental - -Gemini implementation of LangChain's embedding interface. Supports document and query -embedding generation through Gemini's OpenAI compatible API. -Checkout docs here: https://ai.google.dev/gemini-api/docs/openai#embeddings --} -module Langchain.Embeddings.Gemini - ( -- * Types - GeminiEmbeddings (..) - , defaultGeminiEmbeddings - , module Langchain.Embeddings.Core - ) where - -import Data.Text (Text, unpack) -import GHC.Generics -import Langchain.Embeddings.Core -import Langchain.Embeddings.OpenAI - -data GeminiEmbeddings = GeminiEmbeddings - { apiKey :: Text - -- ^ Gemini API Key - , baseUrl :: Maybe String - -- ^ base url; default "https://generativelanguage.googleapis.com/v1beta/openai" - , model :: Text - -- ^ Model name for embeddings - , dimensions :: Maybe Int - -- ^ The number of dimensions the resulting output embeddings should have. - , encodingFormat :: Maybe EncodingFormat - {- ^ The format to return the embeddings in. - ^ For now, only float is supported - -} - , embeddingsUser :: Maybe Text - -- ^ A unique identifier representing your end-user, which can help monitor and detect abuse. - , timeout :: Maybe Int - -- ^ Override default responsetime out. unit = seconds. - } - deriving (Eq, Generic) - -instance Show GeminiEmbeddings where - show GeminiEmbeddings {..} = "GeminiEmbeddings " <> "model " <> unpack model - --- | Default values GeminiEmbeddings, api-key is empty -defaultGeminiEmbeddings :: GeminiEmbeddings -defaultGeminiEmbeddings = - GeminiEmbeddings - { apiKey = "" - , baseUrl = pure "https://generativelanguage.googleapis.com/v1beta/openai" - , model = "gemini-embedding-001" - , dimensions = Nothing - , encodingFormat = Nothing - , embeddingsUser = Nothing - , timeout = Nothing - } - -instance Embeddings GeminiEmbeddings where - embedDocuments GeminiEmbeddings {..} = embedDocuments OpenAIEmbeddings {..} - embedQuery GeminiEmbeddings {..} = embedQuery OpenAIEmbeddings {..} diff --git a/src/Langchain/Embeddings/Ollama.hs b/src/Langchain/Embeddings/Ollama.hs --- a/src/Langchain/Embeddings/Ollama.hs +++ b/src/Langchain/Embeddings/Ollama.hs @@ -1,119 +1,75 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {- | Module : Langchain.Embeddings.Ollama Description : Ollama integration for text embeddings in LangChain Haskell -Copyright : (c) 2025 Tushar Adhatrao +Copyright : (c) 2025-2026 Tushar Adhatrao License : MIT Maintainer : Tushar Adhatrao Stability : experimental -Ollama implementation of LangChain's embedding interface. Supports document and query -embedding generation through Ollama's API. - -Example usage: - -@ --- Create Ollama embeddings configuration -ollamaEmb = OllamaEmbeddings - { model = "nomic-embed-text:latest" - , defaultTruncate = Just True - , defaultKeepAlive = Just "5m" - } - --- Embed query text -queryVec <- embedQuery ollamaEmb "What is Haskell?" --- Right [0.12, 0.34, ...] - --- Embed document collection -doc <- Document "Haskell is a functional programming language" mempty -docsVec <- embedDocuments ollamaEmb [doc] --- Right [[0.56, 0.78, ...]] -@ +Ollama implementation of LangChain's embedding interface using ollama-haskell 0.3.0.0. -} module Langchain.Embeddings.Ollama ( OllamaEmbeddings (..) - , module Langchain.DocumentLoader.Core ) where -import Data.Maybe -import Data.Ollama.Embeddings -import qualified Data.Ollama.Embeddings as O +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (liftIO) import Data.Text (Text) -import qualified Data.Text.Lazy as T -import Langchain.DocumentLoader.Core +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Langchain.Core.Error (llmError) +import Langchain.DocumentLoader.Core (Document (..)) import Langchain.Embeddings.Core -import Langchain.Error (llmError) -import Langchain.Utils (showText) -{- | Ollama-specific embedding configuration -Contains parameters for controlling: - -- Model selection -- Input truncation behavior -- Model caching via keep-alive - -Example configuration: +import Ollama.API.Embed (EmbedRequest (..), EmbedResponse (..), embed) +import Ollama.Client (defaultClient) +import Ollama.Types.Common (ModelName (..)) +import Ollama.Types.Options (ModelOptions) ->>> OllamaEmbeddings "nomic-embed" (Just False) (Just 3600) Nothing -OllamaEmbeddings {model = "nomic-embed", ...} --} data OllamaEmbeddings = OllamaEmbeddings { model :: Text - -- ^ The name of the Ollama model to use for embeddings , defaultTruncate :: Maybe Bool - -- ^ Optional flag to truncate input if supported by the API - , defaultKeepAlive :: Maybe Int - -- ^ Keep model loaded for specified duration in seconds (e.g., 300 for 5 minutes) - , modelOptions :: Maybe O.ModelOptions - -- ^ Optional model parameters (e.g., temperature) as specified in the Modelfile. + , defaultKeepAlive :: Maybe Text + , modelOptions :: Maybe ModelOptions } deriving (Show, Eq) instance Embeddings OllamaEmbeddings where - -- \| Document embedding implementation: - -- Processes each document individually through Ollama's API. - -- - -- Example: - -- >>> let doc = Document "Test content" mempty - -- >>> embedDocuments ollamaEmb [doc] - -- Right [[0.1, 0.2, ...], ...] embedDocuments (OllamaEmbeddings {..}) docs = do - -- For each input text, make an individual API call - eRes <- - embeddingOps - model - (map (T.toStrict . pageContent) docs) - defaultTruncate - defaultKeepAlive - modelOptions - Nothing - Nothing + client <- liftIO defaultClient + let inputs = map (TL.toStrict . pageContent) docs + req = + EmbedRequest + { embModel = ModelName model + , embInput = Right inputs + , embTruncate = defaultTruncate + , embOptions = modelOptions + , embKeepAlive = defaultKeepAlive + , embDimensions = Nothing + } + eRes <- liftIO $ embed client req case eRes of - Left ollamaErr -> return $ Left $ llmError (showText ollamaErr) Nothing Nothing - Right r -> return $ Right $ respondedEmbeddings r + Left ollamaErr -> throwError $ llmError (T.pack (show ollamaErr)) (Just "OllamaEmbeddings") Nothing + Right resp -> pure $ map (map realToFrac) (erEmbeddings resp) - -- \| Query embedding implementation: - -- Generates vector representation for search queries. - -- - -- Example: - -- >>> embedQuery ollamaEmb "Explain monads" - -- Right [0.3, 0.4, ...] - -- embedQuery (OllamaEmbeddings {..}) query = do - res <- - embeddingOps - model - [query] - defaultTruncate - defaultKeepAlive - modelOptions - Nothing - Nothing - case fmap respondedEmbeddings res of - Left err -> pure $ Left (llmError (showText err) Nothing Nothing) - Right lst -> - case listToMaybe lst of - Nothing -> pure $ Left (llmError "Embeddings are empty" Nothing Nothing) - Just x -> pure $ Right x + client <- liftIO defaultClient + let req = + EmbedRequest + { embModel = ModelName model + , embInput = Left query + , embTruncate = defaultTruncate + , embOptions = modelOptions + , embKeepAlive = defaultKeepAlive + , embDimensions = Nothing + } + eRes <- liftIO $ embed client req + case eRes of + Left err -> throwError $ llmError (T.pack (show err)) (Just "OllamaEmbeddings") Nothing + Right resp -> case erEmbeddings resp of + (vec : _) -> pure $ map realToFrac vec + [] -> throwError $ llmError "Embeddings are empty" (Just "OllamaEmbeddings") Nothing diff --git a/src/Langchain/Embeddings/OpenAI.hs b/src/Langchain/Embeddings/OpenAI.hs --- a/src/Langchain/Embeddings/OpenAI.hs +++ b/src/Langchain/Embeddings/OpenAI.hs @@ -1,24 +1,21 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {- | Module : Langchain.Embeddings.OpenAI Description : OpenAI integration for text embeddings in LangChain Haskell -Copyright : (c) 2025 Tushar Adhatrao +Copyright : (c) 2025-2026 Tushar Adhatrao License : MIT Maintainer : Tushar Adhatrao Stability : experimental -OpenAI implementation of LangChain's embedding interface. Supports document and query -embedding generation through OpenAI's API. -Checkout docs here: https://platform.openai.com/docs/guides/embeddings +OpenAI implementation of LangChain's embedding interface. -} module Langchain.Embeddings.OpenAI - ( -- * Types - OpenAIEmbeddings (..) - - -- * Helper model name functions + ( OpenAIEmbeddings (..) , defaultOpenAIEmbeddings , textEmbedding3Small , textEmbedding3Large @@ -26,20 +23,11 @@ , EncodingFormat (..) ) where -{- - No need to expose these, but can be expose later for direct use - -- * Request Types - OpenAIEmbeddingsRequest (..) -, EmbeddingsInput (..) -, EncodingFormat (..) - - -- * ResponseTypes -, OpenAIEmbeddingsResponse (..) -, EmbeddingsObject (..) -, EmbeddingsUsage (..) --} - +import Control.Exception (SomeException, try) +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (liftIO) import Data.Aeson +import qualified Data.ByteString.Lazy as LBS import Data.Maybe import Data.Text (Text, unpack) import qualified Data.Text as T @@ -47,9 +35,10 @@ import qualified Data.Text.Lazy as TL import qualified Data.Vector as V import GHC.Generics + +import Langchain.Core.Error (llmError) import Langchain.DocumentLoader.Core import Langchain.Embeddings.Core -import Langchain.Error (llmError) import Network.HTTP.Conduit import Network.HTTP.Simple ( getResponseBody @@ -57,7 +46,6 @@ , setRequestBodyJSON , setRequestHeader , setRequestMethod - , setRequestSecure ) import Network.HTTP.Types.Status (statusCode) @@ -72,7 +60,6 @@ { inputReq :: EmbeddingsInput , modelReq :: Text , dimensionsReq :: Maybe Int - -- ^ Only supported in text-embedding-3 or later , encodingFormatReq :: Maybe EncodingFormat } deriving (Show, Eq, Generic) @@ -87,12 +74,14 @@ instance ToJSON OpenAIEmbeddingsRequest where toJSON OpenAIEmbeddingsRequest {..} = - object + object $ [ "input" .= inputReq , "model" .= modelReq - , "dimensions" .= dimensionsReq - , "encoding_format" .= encodingFormatReq ] + ++ catMaybes + [ ("dimensions" .=) <$> dimensionsReq + , ("encoding_format" .=) <$> encodingFormatReq + ] -- Response data EmbeddingsUsage = EmbeddingsUsage @@ -117,47 +106,34 @@ deriving (Eq, Show, Generic) instance FromJSON EmbeddingsUsage where - parseJSON (Object v) = + parseJSON = withObject "EmbeddingsUsage" $ \v -> EmbeddingsUsage <$> v .: "prompt_tokens" <*> v .: "total_tokens" - parseJSON _ = error "Parse error, expecting object" instance FromJSON EmbeddingsObject where - parseJSON (Object v) = + parseJSON = withObject "EmbeddingsObject" $ \v -> EmbeddingsObject <$> v .: "embedding" <*> v .:? "index" <*> v .: "object" - parseJSON _ = error "Parse error, expecting object" instance FromJSON OpenAIEmbeddingsResponse where - parseJSON (Object v) = + parseJSON = withObject "OpenAIEmbeddingsResponse" $ \v -> OpenAIEmbeddingsResponse <$> v .: "object" <*> v .: "data" <*> v .: "model" <*> v .:? "usage" - parseJSON _ = error "Parse error, expecting object" --- | Embeddings type for OpenAI, can be used for embed documents with OpenAI. +-- | Embeddings type for OpenAI data OpenAIEmbeddings = OpenAIEmbeddings { apiKey :: Text - -- ^ OpenAI API Key , baseUrl :: Maybe String - -- ^ base url; default "https://api.openai.com/v1" , model :: Text - -- ^ Model name for embeddings , dimensions :: Maybe Int - {- ^ The number of dimensions the resulting output embeddings should have. - ^ Only supported in text-embedding-3 or later - -} , encodingFormat :: Maybe EncodingFormat - {- ^ The format to return the embeddings in. - ^ For now, only float is supported - -} , timeout :: Maybe Int - -- ^ Override default responsetime out. unit = seconds. } deriving (Eq, Generic) @@ -167,76 +143,72 @@ openAIEmbeddingsRequest :: OpenAIEmbeddings -> [Text] -> IO (Either String OpenAIEmbeddingsResponse) openAIEmbeddingsRequest OpenAIEmbeddings {..} txts = do - request_ <- - parseRequest $ - fromMaybe "https://api.openai.com/v1" baseUrl <> "/embeddings" - manager <- - newManager - tlsManagerSettings - { managerResponseTimeout = - responseTimeoutMicro (fromMaybe 60 timeout * 1000000) - } - let req = - setRequestMethod "POST" $ - setRequestSecure True $ - setRequestHeader "Content-Type" ["application/json"] $ - setRequestHeader "Authorization" ["Bearer " <> encodeUtf8 apiKey] $ - setRequestBodyJSON - ( OpenAIEmbeddingsRequest - { inputReq = TextList txts - , modelReq = model - , dimensionsReq = dimensions - , encodingFormatReq = encodingFormat - } - ) - request_ + eReq <- try $ parseRequest $ fromMaybe "https://api.openai.com/v1" baseUrl <> "/embeddings" + case eReq of + Left (err :: SomeException) -> pure $ Left $ "Invalid URL: " ++ show err + Right request_ -> do + manager <- + newManager + tlsManagerSettings + { managerResponseTimeout = + responseTimeoutMicro (fromMaybe 60 timeout * 1000000) + } + let req = + setRequestMethod "POST" $ + setRequestHeader "Content-Type" ["application/json"] $ + setRequestHeader "Authorization" ["Bearer " <> encodeUtf8 apiKey] $ + setRequestBodyJSON + ( OpenAIEmbeddingsRequest + { inputReq = TextList txts + , modelReq = model + , dimensionsReq = dimensions + , encodingFormatReq = encodingFormat + } + ) + request_ - response <- httpLbs req manager - let status = statusCode $ getResponseStatus response - if status >= 200 && status < 300 - then case eitherDecode (getResponseBody response) of - Left err -> return $ Left $ "JSON parse error: " <> err - Right completionResponse -> return $ Right completionResponse - else - return $ - Left $ - "API error: " - <> show status - <> " " - <> show (getResponseBody response) + eResponse <- try (httpLbs req manager) :: IO (Either SomeException (Response LBS.ByteString)) + case eResponse of + Left err -> pure $ Left $ "Network error: " ++ show err + Right response -> do + let status = statusCode $ getResponseStatus response + if status >= 200 && status < 300 + then case eitherDecode (getResponseBody response) of + Left err -> return $ Left $ "JSON parse error: " <> err + Right completionResponse -> return $ Right completionResponse + else + return $ + Left $ + "API error: " + <> show status + <> " " + <> show (getResponseBody response) instance Embeddings OpenAIEmbeddings where embedDocuments openAIEmbeddings docs = do - eRes <- openAIEmbeddingsRequest openAIEmbeddings (map (TL.toStrict . pageContent) docs) + eRes <- liftIO $ openAIEmbeddingsRequest openAIEmbeddings (map (TL.toStrict . pageContent) docs) case eRes of - Left err -> pure $ Left (llmError (T.pack err) Nothing Nothing) - Right (OpenAIEmbeddingsResponse {..}) -> do - pure $ Right $ map embeddings dataList + Left err -> throwError $ llmError (T.pack err) (Just "OpenAIEmbeddings") Nothing + Right (OpenAIEmbeddingsResponse {..}) -> pure $ map embeddings dataList embedQuery openAIEmbeddings query = do - eRes <- openAIEmbeddingsRequest openAIEmbeddings [query] + eRes <- liftIO $ openAIEmbeddingsRequest openAIEmbeddings [query] case eRes of - Left err -> pure $ Left (llmError (T.pack err) Nothing Nothing) - Right (OpenAIEmbeddingsResponse {..}) -> do + Left err -> throwError $ llmError (T.pack err) (Just "OpenAIEmbeddings") Nothing + Right (OpenAIEmbeddingsResponse {..}) -> case listToMaybe dataList of - Nothing -> pure $ Left (llmError "Embeddings are empty" Nothing Nothing) - Just x -> pure $ Right $ embeddings x - --- Helper functions, model name functions + Nothing -> throwError $ llmError "Embeddings are empty" (Just "OpenAIEmbeddings") Nothing + Just x -> pure $ embeddings x --- | Small embedding model textEmbedding3Small :: Text textEmbedding3Small = "text-embedding-3-small" --- | Most capable embedding model textEmbedding3Large :: Text textEmbedding3Large = "text-embedding-3-large" --- | Older embedding model textEmbeddingAda :: Text textEmbeddingAda = "text-embedding-ada-002" --- | Default values OpenAIEmbeddings, api-key is empty defaultOpenAIEmbeddings :: OpenAIEmbeddings defaultOpenAIEmbeddings = OpenAIEmbeddings diff --git a/src/Langchain/Error.hs b/src/Langchain/Error.hs deleted file mode 100644 --- a/src/Langchain/Error.hs +++ /dev/null @@ -1,609 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -{- | -Module : Langchain.Error -Description : Central error handling for langchain-hs -Copyright : (c) 2025 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental - -This module provides a comprehensive error handling system for langchain-hs, -replacing the previous `Either String` pattern with a structured, type-safe -approach that follows industry best practices. - -The error system includes: - -* Structured error types with context and metadata -* Error severity levels and categories -* Utility functions for error construction and handling -* Integration with existing langchain-hs components -* Support for error chaining and context preservation - -Example usage: - -@ -import Langchain.Error - --- Creating errors -let err = llmError "Model timeout" (Just "gpt-4") Nothing - --- Error handling with context -result <- someOperation -case result of - Left err -> do - logError err - handleError err - Right value -> processValue value - --- Error chaining -chainError "Failed to process document" originalError -@ --} -module Langchain.Error - ( -- * Error Types - LangchainError (..) - , ErrorSeverity (..) - , ErrorCategory (..) - , ErrorContext (..) - - -- * Error Construction - , llmError - , llmErrorWithContext - , agentError - , agentErrorWithContext - , memoryError - , memoryErrorWithContext - , toolError - , toolErrorWithContext - , vectorStoreError - , vectorStoreErrorWithContext - , documentLoaderError - , documentLoaderErrorWithContext - , embeddingError - , embeddingErrorWithContext - , runnableError - , runnableErrorWithContext - , parsingError - , parsingErrorWithContext - , networkError - , networkErrorWithContext - , configurationError - , configurationErrorWithContext - , validationError - , validationErrorWithContext - , internalError - , internalErrorWithContext - - -- * Error Utilities - , chainError - , addContext - , withErrorContext - , mapError - , fromString - , toString - , toText - , logError - , isRetryable - , getSeverity - , getCategory - , fromStringError - , fromException - , liftStringError - , simpleError - , catchToLangchainError - , withContext - , withContextIO - - -- * Type Aliases - , LangchainResult - , LangchainIO - - -- * Re-exports for convenience - , module Control.Exception - ) where - -import Control.Exception (Exception, SomeException, displayException, try) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Aeson (FromJSON, ToJSON) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time (UTCTime, getCurrentTime) -import GHC.Generics (Generic) -import System.IO (hPutStrLn, stderr) - --- | Severity levels for errors, following industry standards -data ErrorSeverity - = -- | System-breaking errors that require immediate attention - Critical - | -- | Errors that prevent core functionality - High - | -- | Errors that degrade functionality but allow continuation - Medium - | -- | Minor errors or warnings - Low - | -- | Informational messages - Info - deriving (Eq, Ord, Show, Generic, ToJSON, FromJSON) - --- | Categories of errors for better organization and handling -data ErrorCategory - = -- | Language model related errors - LLMError - | -- | Agent execution errors - AgentError - | -- | Memory management errors - MemoryError - | -- | Tool execution errors - ToolError - | -- | Vector store operation errors - VectorStoreError - | -- | Document loading errors - DocumentLoaderError - | -- | Embedding generation errors - EmbeddingError - | -- | Runnable execution errors - RunnableError - | -- | Data parsing and validation errors - ParsingError - | -- | Network and HTTP errors - NetworkError - | -- | Configuration and setup errors - ConfigurationError - | -- | Input validation errors - ValidationError - | -- | Internal system errors - InternalError - deriving (Eq, Show, Generic, ToJSON, FromJSON) - --- | Additional context information for errors -data ErrorContext = ErrorContext - { contextComponent :: Maybe Text - -- ^ Component where error occurred - , contextOperation :: Maybe Text - -- ^ Operation being performed - , contextInput :: Maybe Text - -- ^ Input that caused the error - , contextMetadata :: [(Text, Text)] - -- ^ Additional metadata - , contextTimestamp :: UTCTime - -- ^ When the error occurred - } - deriving (Eq, Show, Generic, ToJSON, FromJSON) - --- | The central error type for langchain-hs -data LangchainError = LangchainError - { errorMessage :: Text - -- ^ Human-readable error message - , errorSeverity :: ErrorSeverity - -- ^ Severity level - , errorCategory :: ErrorCategory - -- ^ Error category - , errorContext :: Maybe ErrorContext - -- ^ Additional context - , errorCause :: Maybe LangchainError - -- ^ Chained/nested error - , errorCode :: Maybe Text - -- ^ Optional error code - } - deriving (Eq, Show, Generic, ToJSON, FromJSON) - -instance Exception LangchainError where - displayException LangchainError {..} = - T.unpack $ - T.unlines $ - filter - (not . T.null) - [ "[" - <> T.pack (show errorSeverity) - <> "] " - <> T.pack (show errorCategory) - <> ": " - <> errorMessage - , maybe "" ("Error Code: " <>) errorCode - , maybe "" formatContext errorContext - , maybe "" (\cause -> "Caused by: " <> T.pack (show cause)) errorCause - ] - where - formatContext ErrorContext {..} = - T.unlines $ - filter - (not . T.null) - [ maybe "" ("Component: " <>) contextComponent - , maybe "" ("Operation: " <>) contextOperation - , maybe "" ("Input: " <>) contextInput - , if null contextMetadata then "" else "Metadata: " <> T.pack (show contextMetadata) - , "Timestamp: " <> T.pack (show contextTimestamp) - ] - --- | Type alias for results that can fail with LangchainError -type LangchainResult a = Either LangchainError a - --- | Type alias for IO operations that can fail with LangchainError -type LangchainIO a = IO (LangchainResult a) - --- | Create an LLM-related error -llmError :: Text -> Maybe Text -> Maybe Text -> LangchainError -llmError msg _model _operation = - LangchainError - { errorMessage = msg - , errorSeverity = High - , errorCategory = LLMError - , errorContext = Nothing - , errorCause = Nothing - , errorCode = Nothing - } - --- | Create an LLM error with context -llmErrorWithContext :: - Text -> - Maybe Text -> - Maybe Text -> - ErrorContext -> - LangchainError -llmErrorWithContext msg model operation ctx = - (llmError msg model operation) - { errorContext = - Just ctx {contextComponent = model, contextOperation = operation} - } - --- | Create an agent-related error -agentError :: Text -> Maybe Text -> Maybe Text -> LangchainError -agentError msg _agentType _operation = - LangchainError - { errorMessage = msg - , errorSeverity = High - , errorCategory = AgentError - , errorContext = Nothing - , errorCause = Nothing - , errorCode = Nothing - } - --- | Create an agent error with context -agentErrorWithContext :: Text -> Maybe Text -> Maybe Text -> ErrorContext -> LangchainError -agentErrorWithContext msg agentType operation ctx = - (agentError msg agentType operation) - { errorContext = Just ctx {contextComponent = agentType, contextOperation = operation} - } - --- | Create a memory-related error -memoryError :: Text -> Maybe Text -> Maybe Text -> LangchainError -memoryError msg _memoryType _operation = - LangchainError - { errorMessage = msg - , errorSeverity = Medium - , errorCategory = MemoryError - , errorContext = Nothing - , errorCause = Nothing - , errorCode = Nothing - } - --- | Create a memory error with context -memoryErrorWithContext :: Text -> Maybe Text -> Maybe Text -> ErrorContext -> LangchainError -memoryErrorWithContext msg memoryType operation ctx = - (memoryError msg memoryType operation) - { errorContext = Just ctx {contextComponent = memoryType, contextOperation = operation} - } - --- | Create a tool-related error -toolError :: Text -> Maybe Text -> Maybe Text -> LangchainError -toolError msg _toolName _operation = - LangchainError - { errorMessage = msg - , errorSeverity = High - , errorCategory = ToolError - , errorContext = Nothing - , errorCause = Nothing - , errorCode = Nothing - } - --- | Create a tool error with context -toolErrorWithContext :: Text -> Maybe Text -> Maybe Text -> ErrorContext -> LangchainError -toolErrorWithContext msg toolName operation ctx = - (toolError msg toolName operation) - { errorContext = Just ctx {contextComponent = toolName, contextOperation = operation} - } - --- | Create a vector store error -vectorStoreError :: Text -> Maybe Text -> Maybe Text -> LangchainError -vectorStoreError msg _storeType _operation = - LangchainError - { errorMessage = msg - , errorSeverity = High - , errorCategory = VectorStoreError - , errorContext = Nothing - , errorCause = Nothing - , errorCode = Nothing - } - --- | Create a vector store error with context -vectorStoreErrorWithContext :: Text -> Maybe Text -> Maybe Text -> ErrorContext -> LangchainError -vectorStoreErrorWithContext msg storeType operation ctx = - (vectorStoreError msg storeType operation) - { errorContext = Just ctx {contextComponent = storeType, contextOperation = operation} - } - --- | Create a document loader error -documentLoaderError :: Text -> Maybe Text -> Maybe Text -> LangchainError -documentLoaderError msg _loaderType _operation = - LangchainError - { errorMessage = msg - , errorSeverity = Medium - , errorCategory = DocumentLoaderError - , errorContext = Nothing - , errorCause = Nothing - , errorCode = Nothing - } - --- | Create a document loader error with context -documentLoaderErrorWithContext :: Text -> Maybe Text -> Maybe Text -> ErrorContext -> LangchainError -documentLoaderErrorWithContext msg loaderType operation ctx = - (documentLoaderError msg loaderType operation) - { errorContext = Just ctx {contextComponent = loaderType, contextOperation = operation} - } - --- | Create an embedding error -embeddingError :: Text -> Maybe Text -> Maybe Text -> LangchainError -embeddingError msg _embeddingType _operation = - LangchainError - { errorMessage = msg - , errorSeverity = High - , errorCategory = EmbeddingError - , errorContext = Nothing - , errorCause = Nothing - , errorCode = Nothing - } - --- | Create an embedding error with context -embeddingErrorWithContext :: Text -> Maybe Text -> Maybe Text -> ErrorContext -> LangchainError -embeddingErrorWithContext msg embeddingType operation ctx = - (embeddingError msg embeddingType operation) - { errorContext = Just ctx {contextComponent = embeddingType, contextOperation = operation} - } - --- | Create a runnable error -runnableError :: Text -> Maybe Text -> Maybe Text -> LangchainError -runnableError msg _runnableType _operation = - LangchainError - { errorMessage = msg - , errorSeverity = High - , errorCategory = RunnableError - , errorContext = Nothing - , errorCause = Nothing - , errorCode = Nothing - } - --- | Create a runnable error with context -runnableErrorWithContext :: Text -> Maybe Text -> Maybe Text -> ErrorContext -> LangchainError -runnableErrorWithContext msg runnableType operation ctx = - (runnableError msg runnableType operation) - { errorContext = Just ctx {contextComponent = runnableType, contextOperation = operation} - } - --- | Create a parsing error -parsingError :: Text -> Maybe Text -> Maybe Text -> LangchainError -parsingError msg _parserType _input = - LangchainError - { errorMessage = msg <> fromMaybe "" _parserType - , errorSeverity = Medium - , errorCategory = ParsingError - , errorContext = Nothing - , errorCause = Nothing - , errorCode = _input - } - --- | Create a parsing error with context -parsingErrorWithContext :: Text -> Maybe Text -> Maybe Text -> ErrorContext -> LangchainError -parsingErrorWithContext msg parserType input ctx = - (parsingError msg parserType input) - { errorContext = Just ctx {contextComponent = parserType, contextInput = input} - } - --- | Create a network error -networkError :: Text -> Maybe Text -> Maybe Text -> LangchainError -networkError msg _endpoint _operation = - LangchainError - { errorMessage = msg - , errorSeverity = High - , errorCategory = NetworkError - , errorContext = Nothing - , errorCause = Nothing - , errorCode = Nothing - } - --- | Create a network error with context -networkErrorWithContext :: Text -> Maybe Text -> Maybe Text -> ErrorContext -> LangchainError -networkErrorWithContext msg endpoint operation ctx = - (networkError msg endpoint operation) - { errorContext = Just ctx {contextComponent = endpoint, contextOperation = operation} - } - --- | Create a configuration error -configurationError :: Text -> Maybe Text -> Maybe Text -> LangchainError -configurationError msg _configKey _operation = - LangchainError - { errorMessage = msg - , errorSeverity = Critical - , errorCategory = ConfigurationError - , errorContext = Nothing - , errorCause = Nothing - , errorCode = Nothing - } - --- | Create a configuration error with context -configurationErrorWithContext :: Text -> Maybe Text -> Maybe Text -> ErrorContext -> LangchainError -configurationErrorWithContext msg configKey operation ctx = - (configurationError msg configKey operation) - { errorContext = Just ctx {contextComponent = configKey, contextOperation = operation} - } - --- | Create a validation error -validationError :: Text -> Maybe Text -> Maybe Text -> LangchainError -validationError msg _field _input = - LangchainError - { errorMessage = msg - , errorSeverity = Medium - , errorCategory = ValidationError - , errorContext = Nothing - , errorCause = Nothing - , errorCode = Nothing - } - --- | Create a validation error with context -validationErrorWithContext :: Text -> Maybe Text -> Maybe Text -> ErrorContext -> LangchainError -validationErrorWithContext msg field input ctx = - (validationError msg field input) - { errorContext = Just ctx {contextComponent = field, contextInput = input} - } - --- | Create an internal error -internalError :: Text -> Maybe Text -> Maybe Text -> LangchainError -internalError msg _component _operation = - LangchainError - { errorMessage = msg - , errorSeverity = Critical - , errorCategory = InternalError - , errorContext = Nothing - , errorCause = Nothing - , errorCode = Nothing - } - --- | Create an internal error with context -internalErrorWithContext :: Text -> Maybe Text -> Maybe Text -> ErrorContext -> LangchainError -internalErrorWithContext msg component operation ctx = - (internalError msg component operation) - { errorContext = Just ctx {contextComponent = component, contextOperation = operation} - } - --- | Chain an error with a new message, preserving the original as the cause -chainError :: Text -> LangchainError -> LangchainError -chainError msg originalError = - LangchainError - { errorMessage = msg - , errorSeverity = errorSeverity originalError - , errorCategory = errorCategory originalError - , errorContext = errorContext originalError - , errorCause = Just originalError - , errorCode = errorCode originalError - } - --- | Add context to an existing error -addContext :: ErrorContext -> LangchainError -> LangchainError -addContext ctx err = err {errorContext = Just ctx} - --- | Execute an action with error context, automatically adding context to any errors -withErrorContext :: MonadIO m => ErrorContext -> LangchainIO a -> m (LangchainResult a) -withErrorContext ctx action = liftIO $ do - result <- action - case result of - Left err -> return $ Left $ addContext ctx err - Right val -> return $ Right val - --- | Map a function over the error in a result -mapError :: (LangchainError -> LangchainError) -> LangchainResult a -> LangchainResult a -mapError f (Left err) = Left (f err) -mapError _ (Right val) = Right val - --- | Convert a String to LangchainError -fromString :: String -> LangchainError -fromString str = internalError (T.pack str) Nothing Nothing - --- | Convert LangchainError to String -toString :: LangchainError -> String -toString = displayException - --- | Convert LangchainError to Text -toText :: LangchainError -> Text -toText = T.pack . toString - --- | Log an error to stderr (can be extended to use proper logging) -logError :: MonadIO m => LangchainError -> m () -logError err = liftIO $ hPutStrLn stderr $ toString err - --- | Check if an error is retryable based on its category and severity -isRetryable :: LangchainError -> Bool -isRetryable LangchainError {..} = case errorCategory of - NetworkError -> errorSeverity <= High - LLMError -> errorSeverity <= Medium - VectorStoreError -> errorSeverity <= Medium - EmbeddingError -> errorSeverity <= Medium - ToolError -> errorSeverity <= Medium - _ -> False - --- | Get the severity of an error -getSeverity :: LangchainError -> ErrorSeverity -getSeverity = errorSeverity - --- | Get the category of an error -getCategory :: LangchainError -> ErrorCategory -getCategory = errorCategory - --- | Convert a String error to LangchainError (for backward compatibility) -fromStringError :: String -> LangchainError -fromStringError = fromString - --- | Convert an IO exception to LangchainError -fromException :: SomeException -> LangchainError -fromException ex = internalError (T.pack $ displayException ex) Nothing Nothing - --- | Lift an Either String to LangchainResult -liftStringError :: Either String a -> LangchainResult a -liftStringError (Left err) = Left (fromString err) -liftStringError (Right val) = Right val - --- | Create a simple error with just a message (uses InternalError category) -simpleError :: Text -> LangchainError -simpleError msg = internalError msg Nothing Nothing - --- | Catch IO exceptions and convert them to LangchainError -catchToLangchainError :: IO a -> IO (LangchainResult a) -catchToLangchainError action = do - result <- try action - case result of - Left ex -> return $ Left $ fromException ex - Right val -> return $ Right val - --- | Run an action and add context to any errors -withContext :: Text -> Text -> LangchainResult a -> LangchainResult a -withContext component operation result = case result of - Left err -> - case errorContext err of - Just ctx -> - Left $ - err - { errorContext = - Just $ - ErrorContext - { contextComponent = Just component - , contextOperation = Just operation - , contextInput = Nothing - , contextMetadata = [] - , contextTimestamp = contextTimestamp ctx - } - } - Nothing -> Left err - Right val -> Right val - --- | Run an action and add context to any errors (IO version) -withContextIO :: MonadIO m => Text -> Text -> LangchainResult a -> m (LangchainResult a) -withContextIO component operation result = case result of - Left err -> do - now <- liftIO getCurrentTime - return $ - Left $ - err - { errorContext = - Just $ - ErrorContext - { contextComponent = Just component - , contextOperation = Just operation - , contextInput = Nothing - , contextMetadata = [] - , contextTimestamp = now - } - } - Right val -> return $ Right val diff --git a/src/Langchain/Guardrail/Core.hs b/src/Langchain/Guardrail/Core.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Guardrail/Core.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Langchain.Guardrail.Core +Description : Agent input/output validation guardrails and safety filters +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Composable guardrails for validating prompt safety, topic restriction, and response format constraints. +-} +module Langchain.Guardrail.Core + ( GuardrailResult (..) + , Guardrail (..) + , contentSafetyGuardrail + , topicGuardrail + , outputLengthGuardrail + , composeGuardrails + , withGuardrails + ) where + +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.IO.Class (MonadIO) +import Data.Text (Text) +import qualified Data.Text as T + +import Langchain.Core.Error (LangchainError, agentError) +import Langchain.Core.Model + ( ChatModel (..) + , extractMessageText + , userMessage + ) + +-- | Outcome of evaluating a guardrail check +data GuardrailResult + = GuardrailPass + | GuardrailFail !Text -- Reason for failure + deriving (Show, Eq) + +-- | Composable guardrail container +data Guardrail m = Guardrail + { guardrailName :: !Text + , validateInput :: Text -> m GuardrailResult + , validateOutput :: Text -> m GuardrailResult + } + +-- | Simple keyword-based content safety guardrail +contentSafetyGuardrail :: MonadIO m => [Text] -> Guardrail m +contentSafetyGuardrail forbiddenWords = + Guardrail + { guardrailName = "ContentSafety" + , validateInput = \input -> + let lower = T.toLower input + matched = filter (`T.isInfixOf` lower) (map T.toLower forbiddenWords) + in pure $ + if null matched + then GuardrailPass + else GuardrailFail ("Input contains forbidden content: " <> T.intercalate ", " matched) + , validateOutput = \output -> + let lower = T.toLower output + matched = filter (`T.isInfixOf` lower) (map T.toLower forbiddenWords) + in pure $ + if null matched + then GuardrailPass + else GuardrailFail ("Output contains forbidden content: " <> T.intercalate ", " matched) + } + +-- | Output length guardrail +outputLengthGuardrail :: MonadIO m => Int -> Guardrail m +outputLengthGuardrail maxLen = + Guardrail + { guardrailName = "OutputLength" + , validateInput = \_ -> pure GuardrailPass + , validateOutput = \out -> + if T.length out <= maxLen + then pure GuardrailPass + else + pure $ + GuardrailFail + ("Output length (" <> T.pack (show (T.length out)) <> ") exceeds limit of " <> T.pack (show maxLen)) + } + +-- | LLM-based topic relevance guardrail +topicGuardrail :: + (ChatModel model, MonadIO m, MonadError LangchainError m) => model -> Text -> Guardrail m +topicGuardrail model allowedTopic = + Guardrail + { guardrailName = "TopicRestriction" + , validateInput = \input -> do + let prompt = + "Allowed Topic: " + <> allowedTopic + <> "\n\nUser Input: " + <> input + <> "\nIs the user input relevant to the allowed topic? Reply ONLY with 'YES' or 'NO: '." + resp <- invoke model [userMessage prompt] Nothing + let ans = T.strip (extractMessageText resp) + pure $ + if "YES" `T.isPrefixOf` ans + then GuardrailPass + else GuardrailFail ("Topic violation: " <> ans) + , validateOutput = \_ -> pure GuardrailPass + } + +-- | Compose multiple guardrails in sequence +composeGuardrails :: (MonadIO m) => [Guardrail m] -> Guardrail m +composeGuardrails [] = + Guardrail "NoOp" (\_ -> pure GuardrailPass) (\_ -> pure GuardrailPass) +composeGuardrails rails = + Guardrail + { guardrailName = T.intercalate "+" (map guardrailName rails) + , validateInput = checkAll (map validateInput rails) + , validateOutput = checkAll (map validateOutput rails) + } + where + checkAll [] _ = pure GuardrailPass + checkAll (v : vs) txt = do + res <- v txt + case res of + GuardrailPass -> checkAll vs txt + failRes -> pure failRes + +-- | Execute an action wrapped by input and output guardrails +withGuardrails :: + (MonadIO m, MonadError LangchainError m) => + Guardrail m -> + (Text -> m Text) -> + Text -> + m Text +withGuardrails rail action input = do + inRes <- validateInput rail input + case inRes of + GuardrailFail reason -> + throwError $ agentError ("Input guardrail failed: " <> reason) (Just (guardrailName rail)) Nothing + GuardrailPass -> do + output <- action input + outRes <- validateOutput rail output + case outRes of + GuardrailFail reason -> + throwError $ agentError ("Output guardrail failed: " <> reason) (Just (guardrailName rail)) Nothing + GuardrailPass -> pure output diff --git a/src/Langchain/LLM/Core.hs b/src/Langchain/LLM/Core.hs deleted file mode 100644 --- a/src/Langchain/LLM/Core.hs +++ /dev/null @@ -1,321 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} - -{- | -Module: Langchain.LLM.Core -Copyright: (c) 2025 Tushar Adhatrao -License: MIT -Description: Core implementation of langchain LLMs -Maintainer: Tushar Adhatrao -Stability: experimental - -This module provides the core types and typeclasses for the Langchain library in Haskell, -which is designed to facilitate interaction with language models (LLMs). - -It defines a standardized interface that allows different LLM implementations -to be used interchangeably, promoting code reuse and modularity. - -The main components include: - -* The 'LLM' typeclass, which defines the interface for language models. - -* Data types such as 'Message' for conversation messages, - and 'StreamHandler' for handling streaming responses. - -* Default values like 'defaultParams' and 'defaultMessageData' for convenience. - -This module is intended to be used as the foundation for building applications that interact with LLMs, -providing a consistent API across different model implementations. --} -module Langchain.LLM.Core - ( -- * LLM Typeclass - LLM (..) - - -- * Parameters - , Message (..) - , Role (..) - , ChatHistory - , MessageData (..) - , ToolCall (..) - , ToolFunction (..) - , StreamHandler (..) - , MessageConvertible (..) - - -- * Default Values - , defaultMessage - , defaultMessageData - ) where - -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Aeson -import qualified Data.Aeson.KeyMap as KM -import Data.List.NonEmpty -import qualified Data.Map as HM -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) -import GHC.Generics -import Langchain.Error (LangchainResult) - -{- | Callbacks for handling streaming responses from a language model. -This allows real-time processing of tokens as they are generated and an action -upon completion. - -@ -printHandler :: StreamHandler -printHandler = StreamHandler - { onToken = putStrLn . ("Token: " ++) - , onComplete = putStrLn "Streaming complete" - } -@ --} -data StreamHandler tokenType = StreamHandler - { onToken :: tokenType -> IO () - -- ^ Action to perform for each token received - , onComplete :: IO () - -- ^ Action to perform when streaming is complete - } - --- | Enumeration of possible roles in a conversation. -data Role - = -- | System role, typically for instructions or context - System - | -- | User role, for user inputs - User - | -- | Assistant role, for model responses - Assistant - | -- | Tool role, for tool outputs or interactions - Tool - | -- | Developer role for developer messages. Specific to only some integrations - Developer - | -- | Function role for function call messages. Specific to only some integrations - Function - deriving - ( Eq - , Show - , Generic - , ToJSON - , FromJSON - ) - -{- | Represents a message in a conversation, including the sender's role, content, -and additional metadata. -https://python.langchain.com/docs/concepts/messages/ - -@ -userMsg :: Message -userMsg = Message - { role = User - , content = "Explain functional programming" - , messageData = defaultMessageData - } -@ --} -data Message = Message - { role :: Role - -- ^ The role of the message sender - , content :: Text - -- ^ The content of the message - , messageData :: MessageData - -- ^ Additional data associated with the message - } - deriving (Eq, Show) - --- Function call details -data ToolFunction = ToolFunction - { toolFunctionName :: Text - , toolFunctionArguments :: HM.Map Text Value - } - deriving (Show, Eq) - --- Main tool call structure -data ToolCall = ToolCall - { toolCallId :: Text - , toolCallType :: Text - , toolCallFunction :: ToolFunction - } - deriving (Show, Eq) - --- ToJSON instance for ToolFunction -instance ToJSON ToolFunction where - toJSON (ToolFunction name args) = - object - [ "name" .= name - , "arguments" .= args - ] - --- FromJSON instance for ToolFunction -instance FromJSON ToolFunction where - parseJSON = withObject "ToolFunction" $ \obj -> do - name <- obj .: "name" - argsVal <- obj .: "arguments" - args <- case argsVal of - Object o -> pure $ KM.toMapText o - String s -> case decodeStrict (encodeUtf8 s) of - Just (Object o) -> pure $ KM.toMapText o - _ -> fail "ToolFunction.arguments: expected object or JSON-encoded object string" - _ -> fail "ToolFunction.arguments: expected object or string" - return $ ToolFunction name args - --- ToJSON instance for ToolCall -instance ToJSON ToolCall where - toJSON (ToolCall callId callType func) = - object - [ "id" .= callId - , "type" .= callType - , "function" .= func - ] - --- FromJSON instance for ToolCall -instance FromJSON ToolCall where - parseJSON = withObject "ToolCall" $ \obj -> do - callId <- obj .: "id" - callType <- obj .: "type" - func <- obj .: "function" - return $ ToolCall callId callType func - -{- | Additional data for a message, such as a name or tool calls. -This type is designed for extensibility, allowing new fields to be added without -breaking changes. Use 'defaultMessageData' for typical usage. --} -data MessageData = MessageData - { name :: Maybe Text - -- ^ Optional name associated with the message - , toolCalls :: Maybe [ToolCall] - -- ^ Optional list of tool calls invoked by the message - , messageImages :: Maybe [Text] - -- ^ Base64 encoded image data list - , thinking :: Maybe Text - -- ^ Thinking - } - deriving (Eq, Show) - --- | JSON serialization for MessageData. -instance ToJSON MessageData where - toJSON MessageData {..} = - object - [ "name" .= name - , "tool_calls" .= toolCalls - , "images" .= messageImages - , "thinking" .= thinking - -- Add more fields as they are added - ] - --- | JSON deserialization for MessageData. -instance FromJSON MessageData where - parseJSON = withObject "MessageData" $ \v -> - MessageData - <$> v .:? "name" - <*> v .:? "tool_calls" - <*> v .:? "images" - <*> v .:? "thinking" - --- | Type alias for NonEmpty Message -type ChatHistory = NonEmpty Message - --- | Default message with User role and no content. -defaultMessage :: Message -defaultMessage = - Message - { role = User - , content = "" - , messageData = defaultMessageData - } - -{- | Default message data with all fields set to Nothing. -Use this for standard messages without additional metadata --} -defaultMessageData :: MessageData -defaultMessageData = - MessageData - { name = Nothing - , toolCalls = Nothing - , messageImages = Nothing - , thinking = Nothing - } - --- | Typeclass that all ChatModels should interface with -class LLM llm where - -- | Define the Parameter type for your LLM model. - type LLMStreamTokenType llm - - type LLMParams llm - - {- | Invoke the language model with a single prompt. - Suitable for simple queries; returns either an error or generated text. - -} - generate :: - -- | The type of the language model instance. - llm -> - -- | The prompt to send to the model. - Text -> - -- | Optional configuration parameters. - Maybe (LLMParams llm) -> - IO (LangchainResult Text) - - {- | Chat with the language model using a sequence of messages. - Suitable for multi-turn conversations; returns either an error or the response. - -} - chat :: - -- | The type of the language model instance. - llm -> - -- | A non-empty list of messages to send to the model. - ChatHistory -> - -- | Optional configuration parameters. - Maybe (LLMParams llm) -> - -- | The result of the chat, either an error or the response text. - IO (LangchainResult Message) - - {- | Stream responses from the language model for a sequence of messages. - Uses callbacks to process tokens in real-time; returns either an error or unit. - -} - stream :: - llm -> - ChatHistory -> - StreamHandler (LLMStreamTokenType llm) -> - Maybe (LLMParams llm) -> - IO (LangchainResult ()) - - -- Default implementations - - -- | MonadIO version of generate - generateM :: - MonadIO m => - -- | The type of the language model instance. - llm -> - -- | The prompt to send to the model. - Text -> - -- | Optional configuration parameters. - Maybe (LLMParams llm) -> - m (LangchainResult Text) - generateM llm prompt mbParams = liftIO $ generate llm prompt mbParams - - -- | MonadIO version of chat - chatM :: - MonadIO m => - -- | The type of the language model instance. - llm -> - -- | A non-empty list of messages to send to the model. - ChatHistory -> - -- | Optional configuration parameters. - Maybe (LLMParams llm) -> - -- | The result of the chat, either an error or the response text. - m (LangchainResult Message) - chatM llm chatHistory mbParams = liftIO $ chat llm chatHistory mbParams - - -- | MonadIO version of stream - streamM :: - MonadIO m => - llm -> - ChatHistory -> - StreamHandler (LLMStreamTokenType llm) -> - Maybe (LLMParams llm) -> - m (LangchainResult ()) - streamM llm chatHistory sHandler mbParams = - liftIO $ stream llm chatHistory sHandler mbParams - -class MessageConvertible a where - to :: Message -> a - from :: a -> Message diff --git a/src/Langchain/LLM/Deepseek.hs b/src/Langchain/LLM/Deepseek.hs deleted file mode 100644 --- a/src/Langchain/LLM/Deepseek.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} - -{- | -Module : Langchain.LLM.Deepseek -Description : Deepseek integration for LangChain Haskell -Copyright : (c) 2025 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental - -This module provides the 'Deepseek' data type and implements the 'LLM' typeclass for interacting with Deepseek's language models. -It supports generating text, handling chat interactions, and streaming responses using Deepseek's API. - -This implementation uses the OpenAI-compatible interface with baseUrl as "https://api.deepseek.com". - -For more information on Deepseek's API, see: --} -module Langchain.LLM.Deepseek - ( Deepseek (..) - , module Langchain.LLM.Core - ) where - -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import Langchain.Callback -import Langchain.LLM.Core -import qualified Langchain.LLM.Core as LLM -import Langchain.LLM.OpenAICompatible (OpenAICompatible (..)) -import qualified Langchain.Runnable.Core as Run -import qualified OpenAI.V1.Chat.Completions as OpenAIV1 - -data Deepseek = Deepseek - { apiKey :: Text - -- ^ The API key for authenticating with Deepseek's services. - , callbacks :: [Callback] - -- ^ A list of callbacks for handling events during LLM operations. - , baseUrl :: Maybe String - -- ^ Base url; default "https://api.deepseek.com" - } - -instance Show Deepseek where - show _ = "Deepseek" - -toOpenAI :: Deepseek -> OpenAICompatible -toOpenAI Deepseek {..} = - OpenAICompatible - { apiKey = apiKey - , callbacks = callbacks - , baseUrl = Just $ fromMaybe "https://api.deepseek.com" baseUrl - , providerName = "Deepseek" - } - -instance LLM.LLM Deepseek where - type LLMParams Deepseek = OpenAIV1.CreateChatCompletion - type LLMStreamTokenType Deepseek = OpenAIV1.ChatCompletionChunk - - generate deepseek = LLM.generate (toOpenAI deepseek) - chat deepseek = LLM.chat (toOpenAI deepseek) - stream deepseek = LLM.stream (toOpenAI deepseek) - -instance Run.Runnable Deepseek where - type RunnableInput Deepseek = (ChatHistory, Maybe OpenAIV1.CreateChatCompletion) - type RunnableOutput Deepseek = LLM.Message - - invoke = uncurry . chat diff --git a/src/Langchain/LLM/Gemini.hs b/src/Langchain/LLM/Gemini.hs deleted file mode 100644 --- a/src/Langchain/LLM/Gemini.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - -{- | -Module : Langchain.LLM.Gemini -Description : Google Gemini integration for LangChain Haskell -Copyright : (c) 2025 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental - -This module provides the 'Gemini' data type and implements the 'LLM' typeclass for interacting -with Google's Gemini language models through OpenAI-compatible API endpoints. - -The 'Gemini' type encapsulates the API key, model name, and callbacks for event handling. -The 'LLM' instance methods ('generate', 'chat', 'stream') allow for seamless integration -with LangChain's processing pipelines. - -For more information on Gemini API, see: - -Notes: -* Gemini only supports base64 encoded image content. Check out examples. -* Uses OpenAI-compatible endpoint: https://ai.google.dev/gemini-api/docs/openai - -Example usage: - -@ -import Data.Text (Text) -import qualified Langchain.LLM.Core as LLM -import Langchain.LLM.Gemini (Gemini(..), defaultGemini) - -main :: IO() -main = do - let gemini = defaultGemini { apiKey = "your-api-key" } - result <- LLM.generate gemini "Explain functional programming" Nothing - case result of - Left err -> putStrLn $ "Error: " ++ show err - Right response -> print response -@ --} -module Langchain.LLM.Gemini - ( Gemini (..) - , defaultGemini - , module Langchain.LLM.Core - ) where - -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import Langchain.Callback -import Langchain.LLM.Core -import qualified Langchain.LLM.Core as LLM -import Langchain.LLM.OpenAICompatible (OpenAICompatible) -import qualified Langchain.LLM.OpenAICompatible as OpenAICompatible -import qualified Langchain.Runnable.Core as Run -import qualified OpenAI.V1.Chat.Completions as OpenAIV1 - -data Gemini = Gemini - { apiKey :: Text - -- ^ The API key for authenticating with Gemini's services. - , callbacks :: [Callback] - -- ^ A list of callbacks for handling events during LLM operations. - , baseUrl :: Maybe String - -- ^ Base url; default "https://generativelanguage.googleapis.com/v1beta/openai" - } - -instance Show Gemini where - show _ = "Gemini" - -toOpenAI :: Gemini -> OpenAICompatible -toOpenAI Gemini {..} = - OpenAICompatible.OpenAICompatible - { apiKey = apiKey - , callbacks = callbacks - , baseUrl = - Just $ - fromMaybe - "https://generativelanguage.googleapis.com/v1beta/openai" - baseUrl - , providerName = "Gemini" - } - -instance LLM.LLM Gemini where - type LLMParams Gemini = OpenAIV1.CreateChatCompletion - type LLMStreamTokenType Gemini = OpenAIV1.ChatCompletionChunk - - generate = LLM.generate . toOpenAI - chat = LLM.chat . toOpenAI - stream = LLM.stream . toOpenAI - -instance Run.Runnable Gemini where - type RunnableInput Gemini = (ChatHistory, Maybe OpenAIV1.CreateChatCompletion) - type RunnableOutput Gemini = LLM.Message - - invoke = uncurry . chat - -defaultGemini :: Gemini -defaultGemini = - Gemini - { apiKey = "" - , callbacks = [] - , baseUrl = Just "https://generativelanguage.googleapis.com/v1beta/openai" - } diff --git a/src/Langchain/LLM/Huggingface.hs b/src/Langchain/LLM/Huggingface.hs deleted file mode 100644 --- a/src/Langchain/LLM/Huggingface.hs +++ /dev/null @@ -1,243 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} - -{- | -Module: Langchain.LLM.Huggingface -Copyright: (c) 2025 Tushar Adhatrao -License: MIT -Maintainer: Tushar Adhatrao -Stability: experimental - -Huggingface inference implementation Langchain's LLM Interface. -https://huggingface.co/docs/inference-providers/providers/cerebras - -* Support for text generation, chat, and streaming responses -* Configuration of Huggingface-specific parameters (temperature, max tokens, etc.) -* Conversion between Langchain's message format and Huggingface's API requirements -* Compatibility with Huggingface's hosted inference API and other providers --} -module Langchain.LLM.Huggingface - ( -- * Types - Huggingface (..) - , Huggingface.Provider (..) - , HuggingfaceParams (..) - - -- * Functions - , defaultHuggingfaceParams - , Huggingface.defaultHugginfaceMessage - - -- * Re-export - , module LLM - ) where - -import qualified Data.List.NonEmpty as NE -import Data.Maybe -import Data.Text (Text, unpack) -import qualified Data.Text as T -import Langchain.Callback -import Langchain.Error (llmError) -import Langchain.LLM.Core as LLM -import qualified Langchain.LLM.Internal.Huggingface as Huggingface - --- | Configuration for Huggingface LLM integration -data Huggingface = Huggingface - { provider :: Huggingface.Provider - -- ^ Service provider (e.g., HostedInferenceAPI) - , apiKey :: Text - -- ^ Huggingface API authentication key - , modelName :: Text - -- ^ Model identifier (e.g., "google/flan-t5-xl") - , callbacks :: [Callback] - -- ^ Event handlers for inference lifecycle - } - -instance Show Huggingface where - show Huggingface {..} = - "Huggingface { provider = " - <> show provider - <> ", modelName = " - <> unpack modelName - <> " }" - --- | Generation parameters specific to Huggingface models -data HuggingfaceParams = HuggingfaceParams - { frequencyPenalty :: Maybe Double - -- ^ Penalty for token frequency (0.0-2.0) - , maxTokens :: Maybe Integer - -- ^ Token limit for output - , presencePenalty :: Maybe Double - -- ^ Penalty for token presence (0.0-2.0) - , stop :: Maybe [String] - -- ^ Stop sequences to terminate generation - , toolPrompt :: Maybe String - -- ^ Special prompt for tool interactions - , topP :: Maybe Double - -- ^ Nucleus sampling probability threshold - , temperature :: Maybe Double - -- ^ Sampling temperature (0.0-1.0) - , timeout :: Maybe Int - -- ^ Number of seconds for request timeout - } - deriving (Eq, Show) - --- | Default values for huggingface params -defaultHuggingfaceParams :: HuggingfaceParams -defaultHuggingfaceParams = - HuggingfaceParams - { frequencyPenalty = Nothing - , maxTokens = Nothing - , presencePenalty = Nothing - , stop = Nothing - , toolPrompt = Nothing - , topP = Nothing - , temperature = Nothing - , timeout = Just 60 - } - -instance LLM Huggingface where - type LLMParams Huggingface = HuggingfaceParams - type LLMStreamTokenType Huggingface = Text - - generate Huggingface {..} prompt mbHuggingfaceParams = do - eRes <- - Huggingface.createChatCompletion - apiKey - Huggingface.defaultHuggingfaceChatCompletionRequest - { Huggingface.provider = provider - , Huggingface.messages = - [ Huggingface.defaultHugginfaceMessage - { Huggingface.content = Huggingface.TextContent prompt - } - ] - , Huggingface.model = modelName - , Huggingface.stream = False - , Huggingface.maxTokens = maxTokens =<< mbHuggingfaceParams - , Huggingface.frequencyPenalty = frequencyPenalty =<< mbHuggingfaceParams - , -- , Huggingface.logProbs = maybe Nothing logProbs mbHuggingfaceParams - Huggingface.presencePenalty = presencePenalty =<< mbHuggingfaceParams - , -- , Huggingface.seed = maybe Nothing seed mbHuggingfaceParams - Huggingface.stop = stop =<< mbHuggingfaceParams - , Huggingface.temperature = temperature =<< mbHuggingfaceParams - , -- , Huggingface.toolPrompt = maybe Nothing toolPrompt mbHuggingfaceParams - -- , Huggingface.topLogprobs = maybe Nothing topLogProbs mbHuggingfaceParams - Huggingface.topP = topP =<< mbHuggingfaceParams - , Huggingface.timeout = timeout =<< mbHuggingfaceParams - -- , Huggingface.streamOptions = maybe Nothing streamOptions mbHuggingfaceParams - -- , Huggingface.responseFormat = maybe Nothing responseFormat mbHuggingfaceParams - -- , Huggingface.tools = maybe Nothing tools mbHuggingfaceParams - -- , Huggingface.toolChoice = maybe Nothing toolChoice mbHuggingfaceParams - } - case eRes of - Left err -> return $ Left (llmError (T.pack err) Nothing Nothing) - Right r -> do - case listToMaybe ((\Huggingface.ChatCompletionResponse {..} -> choices) r) of - Nothing -> - return $ - Left - (llmError "Did not received any response" Nothing Nothing) - Just resp -> - let Huggingface.Message {..} = Huggingface.message resp - in pure $ - Right $ - ( \case - Huggingface.TextContent t -> t - _ -> "" - ) - content - - chat Huggingface {..} msgs mbHuggingfaceParams = do - eRes <- - Huggingface.createChatCompletion - apiKey - Huggingface.defaultHuggingfaceChatCompletionRequest - { Huggingface.provider = provider - , Huggingface.messages = toHuggingfaceMessages msgs - , Huggingface.model = modelName - , Huggingface.stream = False - , Huggingface.maxTokens = maxTokens =<< mbHuggingfaceParams - , Huggingface.frequencyPenalty = frequencyPenalty =<< mbHuggingfaceParams - , -- , Huggingface.logProbs = maybe Nothing logProbs mbHuggingfaceParams - Huggingface.presencePenalty = presencePenalty =<< mbHuggingfaceParams - , -- , Huggingface.seed = maybe Nothing seed mbHuggingfaceParams - Huggingface.stop = stop =<< mbHuggingfaceParams - , Huggingface.temperature = temperature =<< mbHuggingfaceParams - , -- , Huggingface.toolPrompt = maybe Nothing toolPrompt mbHuggingfaceParams - -- , Huggingface.topLogprobs = maybe Nothing topLogProbs mbHuggingfaceParams - Huggingface.topP = topP =<< mbHuggingfaceParams - , Huggingface.timeout = timeout =<< mbHuggingfaceParams - -- , Huggingface.streamOptions = maybe Nothing streamOptions mbHuggingfaceParams - -- , Huggingface.responseFormat = maybe Nothing responseFormat mbHuggingfaceParams - -- , Huggingface.tools = maybe Nothing tools mbHuggingfaceParams - -- , Huggingface.toolChoice = maybe Nothing toolChoice mbHuggingfaceParams - } - case eRes of - Left err -> return $ Left $ llmError (T.pack err) Nothing Nothing - Right r -> do - case listToMaybe - ((\Huggingface.ChatCompletionResponse {..} -> choices) r) of - Nothing -> - return $ - Left (llmError "Did not received any response" Nothing Nothing) - Just resp -> return $ Right $ from (Huggingface.message resp) - - stream Huggingface {..} msgs LLM.StreamHandler {..} mbHuggingfaceParams = do - eRes <- - Huggingface.createChatCompletionStream - apiKey - Huggingface.defaultHuggingfaceChatCompletionRequest - { Huggingface.provider = provider - , Huggingface.messages = toHuggingfaceMessages msgs - , Huggingface.model = modelName - , Huggingface.stream = True - , Huggingface.maxTokens = maxTokens =<< mbHuggingfaceParams - , Huggingface.frequencyPenalty = frequencyPenalty =<< mbHuggingfaceParams - , -- , Huggingface.logProbs = maybe Nothing logProbs mbHuggingfaceParams - Huggingface.presencePenalty = presencePenalty =<< mbHuggingfaceParams - , -- , Huggingface.seed = maybe Nothing seed mbHuggingfaceParams - Huggingface.stop = stop =<< mbHuggingfaceParams - , Huggingface.temperature = temperature =<< mbHuggingfaceParams - , -- , Huggingface.toolPrompt = maybe Nothing toolPrompt mbHuggingfaceParams - -- , Huggingface.topLogprobs = maybe Nothing topLogProbs mbHuggingfaceParams - Huggingface.topP = topP =<< mbHuggingfaceParams - , Huggingface.timeout = timeout =<< mbHuggingfaceParams - -- , Huggingface.streamOptions = maybe Nothing streamOptions mbHuggingfaceParams - -- , Huggingface.responseFormat = maybe Nothing responseFormat mbHuggingfaceParams - -- , Huggingface.tools = maybe Nothing tools mbHuggingfaceParams - -- , Huggingface.toolChoice = maybe Nothing toolChoice mbHuggingfaceParams - } - Huggingface.HuggingfaceStreamHandler - { Huggingface.onComplete = onComplete - , Huggingface.onToken = onToken . chunkToText - } - case eRes of - Left err -> pure $ Left $ llmError (T.pack err) Nothing Nothing - Right r -> pure $ Right r - where - chunkToText :: Huggingface.ChatCompletionChunk -> Text - chunkToText Huggingface.ChatCompletionChunk {..} = do - case listToMaybe chunkChoices of - Nothing -> "" - Just Huggingface.ChoiceChunk {..} -> - fromMaybe "" ((\Huggingface.Delta {..} -> deltaContent) delta) - -toHuggingfaceMessages :: LLM.ChatHistory -> [Huggingface.Message] -toHuggingfaceMessages msgs = map go (NE.toList msgs) - where - toRole :: LLM.Role -> Huggingface.Role - toRole r = case r of - LLM.System -> Huggingface.System - LLM.User -> Huggingface.User - LLM.Assistant -> Huggingface.Assistant - LLM.Tool -> Huggingface.Tool - _ -> Huggingface.System - -- LLM.Developer -> Huggingface.Developer - -- LLM.Function -> Huggingface.Function - - go :: LLM.Message -> Huggingface.Message - go msg = - Huggingface.defaultHugginfaceMessage - { Huggingface.role = toRole $ LLM.role msg - , Huggingface.content = Huggingface.TextContent (LLM.content msg) - } diff --git a/src/Langchain/LLM/Internal/Huggingface.hs b/src/Langchain/LLM/Internal/Huggingface.hs deleted file mode 100644 --- a/src/Langchain/LLM/Internal/Huggingface.hs +++ /dev/null @@ -1,729 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -{- | -Module: Langchain.LLM.Internal.Huggingface -Copyright: (c) 2025 Tushar Adhatrao -License: MIT -Maintainer: Tushar Adhatrao -Stability: experimental - -Internal types for interfacing with Huggingface. -https://huggingface.co/docs/inference-providers/providers/cerebras --} -module Langchain.LLM.Internal.Huggingface - ( -- * Types - StreamOptions (..) - , HuggingfaceChatCompletionRequest (..) - , Message (..) - , MessageContent (..) - , ImageUrl (..) - , Role (..) - , ContentObject (..) - , Tool_ (..) - , Function_ (..) - , ToolChoice (..) - , SpecificToolChoice (..) - , ResponseFormat (..) - , ChatCompletionResponse (..) - , ChatCompletionChunk (..) - , Choice (..) - , ChoiceChunk (..) - , Usage (..) - , TimeInfo (..) - , ChunkUsage (..) - , ChunkTimeInfo (..) - , Delta (..) - , Provider (..) - , HuggingfaceStreamHandler (..) - - -- * Functions - , providerLinks - , getProviderLink - , createChatCompletion - , defaultHuggingfaceChatCompletionRequest - , defaultHugginfaceMessage - , createChatCompletionStream - , defaultHuggingfaceStreamHandler - ) where - -import Conduit -import Control.Monad (when) -import Data.Aeson -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import Data.IORef -import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) -import GHC.Generics -import qualified Langchain.LLM.Core as LLM -import Network.HTTP.Conduit -import Network.HTTP.Simple - ( getResponseBody - , getResponseStatus - , setRequestBodyJSON - , setRequestHeader - , setRequestMethod - , setRequestSecure - ) -import Network.HTTP.Types.Status (statusCode) - --- | Specifies the format of the response. -data ResponseFormat = RegexFormat String | JsonSchemaFormat Value - deriving (Show, Eq, Generic) - -instance ToJSON ResponseFormat where - toJSON (RegexFormat regEx) = object ["type" .= ("regex" :: Text), "value" .= regEx] - toJSON (JsonSchemaFormat schema) = - object - [ "type" .= ("json" :: Text) - , "value" .= schema - ] - -instance FromJSON ResponseFormat where - parseJSON = withObject "ResponseFormat" $ \v -> do - formatType <- v .: "type" - case formatType of - String "regex" -> RegexFormat <$> v .: "value" - String "json" -> JsonSchemaFormat <$> v .: "value" - _ -> fail $ "Invalid response format type: " ++ show formatType - --- | Represents a tool that can be used in the conversation. -data Tool_ = Tool_ - { toolType :: Text - -- ^ The type of the tool - , function :: Function_ - -- ^ The function associated with the tool - } - deriving (Show, Eq, Generic) - -instance ToJSON Tool_ where - toJSON Tool_ {..} = - object - [ "type" .= toolType - , "function" .= function - ] - -instance FromJSON Tool_ where - parseJSON = withObject "Tool" $ \v -> - Tool_ - <$> v .: "type" - <*> v .: "function" - --- | Represents a function that can be called by the model. -data Function_ = Function_ - { functionName :: Text - -- ^ The name of the function - , description :: Maybe Text - -- ^ Optional description of the function - , arguments :: Maybe Value - -- ^ Optional parameters for the function - } - deriving (Show, Eq, Generic) - -instance ToJSON Function_ where - toJSON Function_ {..} = - object $ - [ "name" .= functionName - ] - ++ maybe [] (\d -> ["description" .= d]) description - ++ maybe [] (\p -> ["arguments" .= p]) arguments - -instance FromJSON Function_ where - parseJSON = withObject "Function" $ \v -> - Function_ - <$> v .: "name" - <*> v .:? "description" - <*> v .:? "arguments" - --- | Specifies how the model should choose tools. -data ToolChoice = None | Auto | Required | SpecificTool SpecificToolChoice - deriving (Show, Eq, Generic) - -instance ToJSON ToolChoice where - toJSON None = String "none" - toJSON Auto = String "auto" - toJSON Required = String "required" - toJSON (SpecificTool choice) = toJSON choice - -instance FromJSON ToolChoice where - parseJSON (String "none") = return None - parseJSON (String "auto") = return Auto - parseJSON (String "required") = return Required - parseJSON o@(Object _) = SpecificTool <$> parseJSON o - parseJSON invalid = fail $ "Invalid tool choice: " ++ show invalid - --- | Provides details for a specific tool choice. -newtype SpecificToolChoice = SpecificToolChoice - { specificToolChoiceFunction :: Value - -- ^ Function details - } - deriving (Show, Eq, Generic) - -instance ToJSON SpecificToolChoice where - toJSON SpecificToolChoice {..} = - object - [ "function" .= specificToolChoiceFunction - ] - -instance FromJSON SpecificToolChoice where - parseJSON = withObject "SpecificToolChoice" $ \v -> - SpecificToolChoice - <$> v .: "function" - --- | Options for streaming responses. -newtype StreamOptions = StreamOptions - { includeUsage :: Bool - -- ^ Whether to include usage information - } - deriving (Show, Eq) - -instance ToJSON StreamOptions where - toJSON StreamOptions {..} = - object - [ "include_usage" .= includeUsage - ] - -instance FromJSON StreamOptions where - parseJSON = withObject "StreamOptions" $ \v -> - StreamOptions <$> v .: "include_usage" - --- | Huggingface supporting Roles -data Role = User | Assistant | Tool | System - deriving (Eq, Show, Generic) - -instance ToJSON Role where - toJSON User = String "user" - toJSON Assistant = String "assistant" - toJSON Tool = String "tool" - toJSON System = String "system" - -instance FromJSON Role where - parseJSON = withText "Role" $ \t -> case t of - "user" -> pure User - "assistant" -> pure Assistant - "tool" -> pure Tool - "system" -> pure System - _ -> fail $ "Unknown role: " ++ T.unpack t - --- | Image url object -newtype ImageUrl = ImageUrl - { url :: String - } - deriving (Eq, Show, Generic) - -instance ToJSON ImageUrl where - toJSON (ImageUrl url) = object ["url" .= url] - -instance FromJSON ImageUrl where - parseJSON = withObject "ImageUrl" $ \v -> - ImageUrl <$> v .: "url" - --- | ContentObject -data ContentObject = ContentObject - { contentType :: Text - , contentText :: Maybe Text - , imageUrl :: Maybe ImageUrl - } - deriving (Eq, Show, Generic) - -instance ToJSON ContentObject where - toJSON (ContentObject contentType contentText imageUrl) = - object $ - ["type" .= contentType] - ++ maybe [] (\t -> ["text" .= t]) contentText - ++ maybe [] (\i -> ["image_url" .= i]) imageUrl - -instance FromJSON ContentObject where - parseJSON = withObject "ContentObject" $ \v -> - ContentObject - <$> v .: "type" - <*> v .:? "text" - <*> v .:? "image_url" - --- | Message could be either simple text or an object -data MessageContent = MessageContent [ContentObject] | TextContent Text - deriving (Eq, Show) - -instance ToJSON MessageContent where - toJSON (MessageContent contentObjects) = toJSON contentObjects - toJSON (TextContent text) = String text - -instance FromJSON MessageContent where - parseJSON v@(String _) = TextContent <$> parseJSON v - parseJSON v = MessageContent <$> parseJSON v - --- | Huggingface's Message type -data Message = Message - { role :: Role - , content :: MessageContent - , name :: Maybe String - } - deriving (Eq, Show, Generic) - --- | Default message type -defaultHugginfaceMessage :: Message -defaultHugginfaceMessage = - Message - { role = User - , content = TextContent "What is the meaning of life?" - , name = Nothing - } - -instance ToJSON Message where - toJSON (Message role content name) = - object $ - ["role" .= role, "content" .= content] - ++ maybe [] (\n -> ["name" .= n]) name - -instance FromJSON Message where - parseJSON = withObject "Message" $ \v -> - Message - <$> v .: "role" - <*> v .: "content" - <*> v .:? "name" - -{- | \$providers -Supported providers and their API endpoints: - -- Cerebras: @https://router.huggingface.co/cerebras/... -- Cohere: @https://router.huggingface.co/cohere/... -- Fireworks: @https://router.huggingface.co/fireworks-ai/... -- HFInference: @https://router.huggingface.co/hf-inference/... --} -getProviderLink :: Provider -> Maybe String -getProviderLink provider = Map.lookup provider providerLinks - --- | Map of Providers to their respective links -providerLinks :: Map.Map Provider String -providerLinks = - Map.fromList - [ (Cerebras, "https://router.huggingface.co/cerebras/v1/chat/completions") - , (Cohere, "https://router.huggingface.co/cohere/compatibility/v1/chat/completions") - , (FalAI, "https://router.huggingface.co/fal-ai/fal-ai/whisper") - , (Fireworks, "https://router.huggingface.co/fireworks-ai/inference/v1/chat/completions") - , (Hyperbolic, "https://router.huggingface.co/hyperbolic/v1/chat/completions") - , (HFInference, "https://router.huggingface.co/hf-inference/models/Qwen/QwQ-32B/v1/chat/completions") - , (Nebius, "https://router.huggingface.co/nebius/v1/chat/completions") - , (Novita, "https://router.huggingface.co/novita/v3/openai/chat/completions") - , (SambaNova, "https://router.huggingface.co/sambanova/v1/chat/completions") - , (Together, "https://router.huggingface.co/together/v1/chat/completions") - ] - -{- | - Providers integrated with Huggingface Inference - https://huggingface.co/docs/inference-providers/index#partners --} -data Provider - = Cerebras - | Cohere - | FalAI - | Fireworks - | HFInference - | Hyperbolic - | Nebius - | Novita - | Replicate - | SambaNova - | Together - deriving (Show, Eq, Ord) - --- | Chat completion request body type. Separatly passes provider. -data HuggingfaceChatCompletionRequest = HuggingfaceChatCompletionRequest - { provider :: Provider - , timeout :: Maybe Int - , messages :: [Message] - , model :: Text - , stream :: Bool - , maxTokens :: Maybe Integer - , frequencyPenalty :: Maybe Double - , logProbs :: Maybe Bool - , presencePenalty :: Maybe Double - , seed :: Maybe Int - , stop :: Maybe [String] - , temperature :: Maybe Double - , toolPrompt :: Maybe String - , topLogprobs :: Maybe Int - , topP :: Maybe Double - , streamOptions :: Maybe StreamOptions - , responseFormat :: Maybe ResponseFormat - , tools :: Maybe [Tool_] - , toolChoice :: Maybe ToolChoice - } - deriving (Eq, Show, Generic) - --- | Default values of chat completion request. -defaultHuggingfaceChatCompletionRequest :: HuggingfaceChatCompletionRequest -defaultHuggingfaceChatCompletionRequest = - HuggingfaceChatCompletionRequest - { provider = Cerebras - , timeout = Nothing - , messages = [defaultHugginfaceMessage] - , model = "llama-3.3-70b" - , stream = False - , maxTokens = Nothing - , frequencyPenalty = Nothing - , logProbs = Nothing - , presencePenalty = Nothing - , seed = Nothing - , stop = Nothing - , temperature = Nothing - , toolPrompt = Nothing - , topLogprobs = Nothing - , topP = Nothing - , streamOptions = Nothing - , responseFormat = Nothing - , tools = Nothing - , toolChoice = Nothing - } - -instance ToJSON HuggingfaceChatCompletionRequest where - toJSON - ( HuggingfaceChatCompletionRequest - _ - _ - messages - model - stream - maxTokens - frequencyPenalty - logProbs - presencePenalty - seed - stop - temperature - toolPrompt - topLogprobs - topP - streamOptions - responseFormat - tools - toolChoice - ) = - object $ - [ "messages" .= messages - , "model" .= model - , "stream" .= stream - ] - ++ optionalField "max_tokens" maxTokens - ++ optionalField "frequency_penalty" frequencyPenalty - ++ optionalField "logprobs" logProbs - ++ optionalField "presence_penalty" presencePenalty - ++ optionalField "seed" seed - ++ optionalField "stop" stop - ++ optionalField "temperature" temperature - ++ optionalField "tool_prompt" toolPrompt - ++ optionalField "top_logprobs" topLogprobs - ++ optionalField "top_p" topP - ++ optionalField "stream_options" streamOptions - ++ optionalField "response_format" responseFormat - ++ optionalField "tools" tools - ++ optionalField "tool_choice" toolChoice - where - optionalField _ Nothing = [] - optionalField key (Just value) = [(key, toJSON value)] - --- | Choice options -data Choice = Choice - { finish_reason :: Text - , index :: Int - , message :: Message - } - deriving (Eq, Show, Generic) - -instance FromJSON Choice where - parseJSON = withObject "Choice" $ \v -> - Choice - <$> v .: "finish_reason" - <*> v .: "index" - <*> v .: "message" - --- | Token usage -data Usage = Usage - { prompt_tokens :: Int - , completion_tokens :: Int - , total_tokens :: Int - } - deriving (Eq, Show, Generic) - -instance FromJSON Usage where - parseJSON = withObject "Usage" $ \v -> - Usage - <$> v .: "prompt_tokens" - <*> v .: "completion_tokens" - <*> v .: "total_tokens" - --- | Timeinfo -data TimeInfo = TimeInfo - { queue_time :: Double - , prompt_time :: Double - , completion_time :: Double - , total_time :: Double - , timeInfoCreated :: Int - } - deriving (Eq, Show, Generic) - -instance FromJSON TimeInfo where - parseJSON = withObject "TimeInfo" $ \v -> - TimeInfo - <$> v .: "queue_time" - <*> v .: "prompt_time" - <*> v .: "completion_time" - <*> v .: "total_time" - <*> v .: "created" - --- | Response type for chat completion -data ChatCompletionResponse = ChatCompletionResponse - { responseId :: Text - , choices :: [Choice] - , created :: Int - , chatCompletionModel :: Text - , system_fingerprint :: Text - , chatCompletionObject :: Text - , usage :: Usage - , time_info :: TimeInfo - } - deriving (Eq, Show, Generic) - -instance FromJSON ChatCompletionResponse where - parseJSON = withObject "ChatCompletion" $ \v -> - ChatCompletionResponse - <$> v .: "id" - <*> v .: "choices" - <*> v .: "created" - <*> v .: "model" - <*> v .: "system_fingerprint" - <*> v .: "object" - <*> v .: "usage" - <*> v .: "time_info" - --- | Response for stream -newtype Delta = Delta - { deltaContent :: Maybe Text - } - deriving (Eq, Show, Generic) - -instance FromJSON Delta where - parseJSON = withObject "Delta" $ \v -> - Delta - <$> v .:? "content" - --- | Represents type for choice object from stream response -data ChoiceChunk = ChoiceChunk - { delta :: Delta - , choiceFinishReason :: Maybe Text - , choiceIndex :: Int - } - deriving (Eq, Show, Generic) - -instance FromJSON ChoiceChunk where - parseJSON = withObject "ChoiceChunk" $ \v -> - ChoiceChunk - <$> v .: "delta" - <*> v .:? "finish_reason" - <*> v .: "index" - --- | Represent type for usage object from stream response -data ChunkUsage = ChunkUsage - { promptTokens :: Int - , usageCompletionTokens :: Int - , usageTotalTokens :: Int - } - deriving (Eq, Show, Generic) - -instance FromJSON ChunkUsage where - parseJSON = withObject "Usage" $ \v -> - ChunkUsage - <$> v .: "prompt_tokens" - <*> v .: "completion_tokens" - <*> v .: "total_tokens" - --- | Represents type for timeinfo object from stream reponse -data ChunkTimeInfo = ChunkTimeInfo - { timeInfoQueueTime :: Double - , timeInfoPromptTime :: Double - , timeInfoCompletionTime :: Double - , timeInfoTotalTime :: Double - , chunkTimeInfoCreated :: Int - } - deriving (Eq, Show, Generic) - -instance FromJSON ChunkTimeInfo where - parseJSON = withObject "TimeInfo" $ \v -> - ChunkTimeInfo - <$> v .: "queue_time" - <*> v .: "prompt_time" - <*> v .: "completion_time" - <*> v .: "total_time" - <*> v .: "created" - --- | Type that represents stream response -data ChatCompletionChunk = ChatCompletionChunk - { chatCompletionChunkId :: Text - , chunkChoices :: [ChoiceChunk] - , chunkCreated :: Int - , chunkModel :: Text - , chunkSystemFingerprint :: Text - , chunkObject :: Text - , chunkUsage :: Maybe Usage - , chunkTimeInfo :: Maybe ChunkTimeInfo - } - deriving (Eq, Show, Generic) - -instance FromJSON ChatCompletionChunk where - parseJSON = withObject "ChatCompletionChunk" $ \v -> - ChatCompletionChunk - <$> v .: "id" - <*> v .: "choices" - <*> v .: "created" - <*> v .: "model" - <*> v .: "system_fingerprint" - <*> v .: "object" - <*> v .:? "usage" - <*> v .:? "time_info" - --- | Chat completion function -createChatCompletion :: - Text -> HuggingfaceChatCompletionRequest -> IO (Either String ChatCompletionResponse) -createChatCompletion apiKey r = do - case getProviderLink (provider r) of - Nothing -> pure $ Left "Incompatible provider" - Just link -> do - request_ <- parseRequest link - manager <- - newManager - tlsManagerSettings - { managerResponseTimeout = - responseTimeoutMicro (fromMaybe 60 (timeout r) * 1000000) - } - let req = - setRequestMethod "POST" $ - setRequestSecure True $ - setRequestHeader "Content-Type" ["application/json"] $ - setRequestHeader "Authorization" ["Bearer " <> encodeUtf8 apiKey] $ - setRequestBodyJSON r request_ - - response <- httpLbs req manager - let status = statusCode $ getResponseStatus response - if status >= 200 && status < 300 - then case eitherDecode (getResponseBody response) of - Left err -> return $ Left $ "JSON parse error: " <> err - Right completionResponse -> return $ Right completionResponse - else - return $ - Left $ - "API error: " - <> show status - <> " " - <> show (getResponseBody response) - -{- | Handler for streaming chat completion responses. -Provides callbacks for processing each token and handling stream completion. --} -data HuggingfaceStreamHandler = HuggingfaceStreamHandler - { onToken :: ChatCompletionChunk -> IO () - -- ^ Callback for each token (chunk) received - , onComplete :: IO () - -- ^ Callback when the stream is complete - } - --- | Default values for stream handling in Huggingface LLM -defaultHuggingfaceStreamHandler :: HuggingfaceStreamHandler -defaultHuggingfaceStreamHandler = - HuggingfaceStreamHandler - { onToken = print - , onComplete = pure () - } - --- | Streaming function for huggingface -createChatCompletionStream :: - Text -> - HuggingfaceChatCompletionRequest -> - HuggingfaceStreamHandler -> - IO (Either String ()) -createChatCompletionStream apiKey r HuggingfaceStreamHandler {..} = do - case getProviderLink (provider r) of - Nothing -> pure $ Left "Incompatible provider" - Just link -> do - request_ <- parseRequest link - let httpReq = - setRequestHeader "Authorization" ["Bearer " <> encodeUtf8 apiKey] $ - setRequestMethod "POST" $ - setRequestSecure True $ - setRequestHeader "Content-Type" ["application/json"] $ - setRequestBodyJSON r request_ - - manager <- - newManager - tlsManagerSettings - { managerResponseTimeout = - responseTimeoutMicro (fromMaybe 60 (timeout r) * 1000000) - } - runResourceT $ do - response <- http httpReq manager - bufferRef <- liftIO $ newIORef BS.empty - runConduit $ - responseBody response - .| linesUnboundedAsciiC - .| mapM_C (liftIO . processLine bufferRef) - - onComplete - return $ Right () - where - processLine bufferRef line = do - when - (BS.isPrefixOf "data: " line) - ( do - do - let content = BS.drop 6 line -- Remove "data: " prefix - case decode (LBS.fromStrict content) of - Just chunk -> onToken chunk - Nothing -> do - -- Handle potential partial JSON by buffering - oldBuffer <- readIORef bufferRef - let newBuffer = oldBuffer <> content - writeIORef bufferRef newBuffer - -- Try to parse the combined buffer - case decode (LBS.fromStrict newBuffer) of - Just chunk -> do - onToken chunk - writeIORef bufferRef BS.empty -- Clear buffer after successful parse - Nothing -> return () -- Keep in buffer for next chunk - ) - -instance LLM.MessageConvertible Message where - -- to :: LLM.Message -> Message - to msg = - defaultHugginfaceMessage - { role = toRole $ LLM.role msg - , content = TextContent (LLM.content msg) - } - where - toRole :: LLM.Role -> Role - toRole r = case r of - LLM.System -> System - LLM.User -> User - LLM.Assistant -> Assistant - LLM.Tool -> Tool - _ -> User - - -- from :: Message -> LLM.Message - from msg = - LLM.Message - { LLM.role = toRole (role msg) - , LLM.content = case content msg of - TextContent txt -> txt - _ -> "" - , LLM.messageData = LLM.defaultMessageData - } - where - toRole :: Role -> LLM.Role - toRole r = case r of - System -> LLM.System - User -> LLM.User - Assistant -> LLM.Assistant - Tool -> LLM.Tool diff --git a/src/Langchain/LLM/Ollama.hs b/src/Langchain/LLM/Ollama.hs deleted file mode 100644 --- a/src/Langchain/LLM/Ollama.hs +++ /dev/null @@ -1,258 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -{- | -Module : Langchain.LLM.Ollama -Description : Ollama integration for LangChain Haskell -Copyright : (c) 2025 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental - -Ollama implementation of LangChain's LLM interface , supporting: - -- Text generation -- Chat interactions -- Streaming responses -- Callback integration - -Example usage: - -@ --- Create Ollama configuration -ollamaLLM = Ollama "gemma3" [stdOutCallback] - --- Generate text -response <- generate ollamaLLM "Explain Haskell monads" Nothing --- Right "Monads in Haskell..." - --- Chat interaction -let messages = UserMessage "What's the capital of France?" :| [] -chatResponse <- chat ollamaLLM messages Nothing --- Right "The capital of France is Paris." - --- Streaming -streamHandler = StreamHandler print (putStrLn "Done") -streamResult <- stream ollamaLLM messages streamHandler Nothing -@ --} -module Langchain.LLM.Ollama - ( Ollama (..) - , defaultOllama - - -- * Re-export - , module Langchain.LLM.Core - ) where - -import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe (fromMaybe) -import qualified Data.Ollama.Chat as OllamaChat -import qualified Data.Ollama.Common.Types as O -import Data.Text (Text) -import qualified Data.Text as T -import Langchain.Callback (Callback, Event (..)) -import Langchain.Error (llmError) -import qualified Langchain.Error as Error -import Langchain.LLM.Core -import qualified Langchain.Runnable.Core as Run - -{- | Ollama LLM configuration -Contains: - -- Model name (e.g., "llama3:latest") -- Callbacks for event tracking - -Example: - ->>> Ollama "nomic-embed" [logCallback] -Ollama "nomic-embed" --} -data Ollama = Ollama - { modelName :: Text - -- ^ The name of the Ollama model - , callbacks :: [Callback] - -- ^ Event handlers for LLM operations - } - -instance Show Ollama where - show (Ollama modelName _) = "Ollama " ++ show modelName - -{- | Ollama implementation of the LLM typeclass -Example instance usage: - -@ --- Generate text with error handling -case generate ollamaLLM "Hello" Nothing of - Left err -> putStrLn $ "Error: " ++ err - Right res -> putStrLn res -@ --} -instance LLM Ollama where - type LLMParams Ollama = OllamaChat.ChatOps - type LLMStreamTokenType Ollama = OllamaChat.ChatResponse - - -- \| Generate text from a prompt - -- Returns Left on API errors, Right on success. - -- - -- Example: - -- >>> generate (Ollama "llama3.2" []) "Hello" Nothing - -- Right "Hello! How can I assist you today?" - generate (Ollama model cbs) prompt mbOllamaParams = do - mapM_ (\cb -> cb LLMStart) cbs - let chatOps_ = fromMaybe OllamaChat.defaultChatOps mbOllamaParams - msg = OllamaChat.userMessage prompt - chatOps = - chatOps_ - { OllamaChat.modelName = model - , OllamaChat.messages = [msg] - } - - eRes <- OllamaChat.chat chatOps Nothing - case eRes of - Left err -> do - mapM_ (\cb -> cb (LLMError $ show err)) cbs - return $ Left (llmError (T.pack $ show err) Nothing Nothing) - Right chatResponse -> do - mapM_ (\cb -> cb LLMEnd) cbs - case OllamaChat.message chatResponse of - Nothing -> pure $ Left (Error.fromString "Message not found in response") - Just m -> pure $ Right $ OllamaChat.content m - - -- \| Chat interaction with message history. - -- Uses Ollama's chat API for multi-turn conversations. - -- - -- Example: - -- >>> let msgs = UserMessage "Hi" :| [AssistantMessage "Hello!"] - -- >>> chat (Ollama "llama3" []) msgs Nothing - -- Right "How are you today?" - chat (Ollama model cbs) messages mbOllamaParams = do - mapM_ (\cb -> cb LLMStart) cbs - let chatOps_ = fromMaybe OllamaChat.defaultChatOps mbOllamaParams - chatOps = - chatOps_ - { OllamaChat.modelName = model - , OllamaChat.messages = NonEmpty.map to messages - } - eRes <- OllamaChat.chat chatOps Nothing - case eRes of - Left err -> do - mapM_ (\cb -> cb (LLMError $ show err)) cbs - return $ Left (llmError (T.pack $ show err) Nothing Nothing) - Right res -> do - mapM_ (\cb -> cb LLMEnd) cbs - case OllamaChat.message res of - Nothing -> - return $ - Left $ - llmError - (T.pack $ "Message field not found: " <> show res) - Nothing - Nothing - Just ollamaMsg -> return $ Right (from ollamaMsg) - - -- \| Streaming response handling. - -- Processes tokens in real-time via StreamHandler. - -- - -- Example: - -- >>> let handler = StreamHandler (putStr . ("Token: " ++)) (putStrLn "Complete") - -- >>> stream (Ollama "llama3" []) messages handler Nothing - -- Token: H Token: i Complete - -- - -- Note: Don't pass streamHandler in ChatOps's stream field. It will be overridden. - stream - (Ollama model_ cbs) - messages - StreamHandler {onToken, onComplete} - mbOllamaParams = do - let chatOps_ = fromMaybe OllamaChat.defaultChatOps mbOllamaParams - chatOps = - chatOps_ - { OllamaChat.modelName = model_ - , OllamaChat.messages = NonEmpty.map to messages - , OllamaChat.stream = - Just - ( onToken - , pure () - ) - } - mapM_ (\cb -> cb LLMStart) cbs - eRes <- OllamaChat.chat chatOps Nothing - case eRes of - Left err -> do - mapM_ (\cb -> cb (LLMError $ show err)) cbs - return $ Left (llmError (T.pack $ show err) Nothing Nothing) - Right _ -> do - onComplete - mapM_ (\cb -> cb LLMEnd) cbs - return $ Right () - -toOllamaRole :: Role -> OllamaChat.Role -toOllamaRole User = OllamaChat.User -toOllamaRole System = OllamaChat.System -toOllamaRole Assistant = OllamaChat.Assistant -toOllamaRole Tool = OllamaChat.Tool -toOllamaRole _ = OllamaChat.User -- Ollama only supports above 4 Roles, others will be defaulted to user - -fromOllamaRole :: OllamaChat.Role -> Role -fromOllamaRole OllamaChat.User = User -fromOllamaRole OllamaChat.System = System -fromOllamaRole OllamaChat.Assistant = Assistant -fromOllamaRole OllamaChat.Tool = Tool - -instance MessageConvertible OllamaChat.Message where - to Message {..} = - OllamaChat.Message - (toOllamaRole role) - content - (messageImages messageData) - (fmap toOllamaToolCall <$> toolCalls messageData) - (thinking messageData) - where - toOllamaToolCall :: ToolCall -> O.ToolCall - toOllamaToolCall ToolCall {..} = - O.ToolCall - { O.outputFunction = - O.OutputFunction - { O.outputFunctionName = toolFunctionName toolCallFunction - , O.arguments = toolFunctionArguments toolCallFunction - } - } - - from (OllamaChat.Message role' content' imgs tools think) = - Message - { role = fromOllamaRole role' - , content = content' - , messageData = - MessageData - { messageImages = imgs - , toolCalls = fmap toToolCall <$> tools - , thinking = think - , name = Nothing - } - } - where - toToolCall :: O.ToolCall -> ToolCall - toToolCall O.ToolCall {..} = - ToolCall - { toolCallId = "" - , toolCallType = "function" - , toolCallFunction = - ToolFunction - { toolFunctionName = O.outputFunctionName outputFunction - , toolFunctionArguments = O.arguments outputFunction - } - } - -instance Run.Runnable Ollama where - type RunnableInput Ollama = (ChatHistory, Maybe OllamaChat.ChatOps) - type RunnableOutput Ollama = Message - - invoke = uncurry . chat - --- | Default values for Ollama -defaultOllama :: Ollama -defaultOllama = Ollama "llama3.2" [] diff --git a/src/Langchain/LLM/OpenAI.hs b/src/Langchain/LLM/OpenAI.hs deleted file mode 100644 --- a/src/Langchain/LLM/OpenAI.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} - -{- | -Module : Langchain.LLM.OpenAI -Description : OpenAI integration for LangChain Haskell -Copyright : (c) 2025 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental - -This module provides the 'OpenAI' data type and implements the 'LLM' typeclass for interacting with OpenAI's language models. -It supports generating text, handling chat interactions, and streaming responses using OpenAI's API. - -The 'OpenAI' type encapsulates the API key, model name, and callbacks for event handling. -The 'LLM' instance methods ('generate', 'chat', 'stream') allow for seamless integration with LangChain's processing pipelines. - -For more information on OpenAI's API, see: - -@ -import Data.Text (Text) -import qualified Langchain.LLM.Core as LLM -import Langchain.LLM.OpenAI (OpenAI(..)) - -main :: IO() -main = do - let openAI = OpenAI - { apiKey = "your-api-key" - , callbacks = [] - , baseUrl = Nothing - } - result <- LLM.generate openAI "Tell me a joke" Nothing - case result of - Left err -> putStrLn $ "Error: " ++ err - Right response -> putStrLn response -@ --} -module Langchain.LLM.OpenAI - ( -- * Types - OpenAI (..) - - -- * Default functions - , defaultOpenAI - - -- * Re-export - , module Langchain.LLM.Core - ) where - -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import Langchain.Callback (Callback) -import Langchain.LLM.Core -import qualified Langchain.LLM.Core as LLM -import Langchain.LLM.OpenAICompatible (OpenAICompatible) -import qualified Langchain.LLM.OpenAICompatible as OpenAICompatible -import qualified Langchain.Runnable.Core as Run -import qualified OpenAI.V1.Chat.Completions as OpenAIV1 - -{- | Configuration for OpenAI's language models. - -This data type holds the necessary information to interact with OpenAI's API, -including the API key, the model name, and a list of callbacks for handling events. --} -data OpenAI = OpenAI - { apiKey :: Text - -- ^ The API key for authenticating with OpenAI's services. - , callbacks :: [Callback] - -- ^ A list of callbacks for handling events during LLM operations. - , baseUrl :: Maybe String - -- ^ Base url; default "https://api.openai.com" - } - --- | Not including API key to avoid accidental leak -instance Show OpenAI where - show _ = "OpenAI" - -toOpenAI :: OpenAI -> OpenAICompatible -toOpenAI OpenAI {..} = - OpenAICompatible.OpenAICompatible - { apiKey = apiKey - , callbacks = callbacks - , baseUrl = - Just $ - fromMaybe - "https://api.openai.com" - baseUrl - , providerName = "OpenAI" - } - -{- | Implementation of the 'LLM' typeclass for OpenAI models. - -This instance provides methods for generating text, handling chat interactions, -and streaming responses using OpenAI's API. --} -instance LLM.LLM OpenAI where - type LLMParams OpenAI = OpenAIV1.CreateChatCompletion - type LLMStreamTokenType OpenAI = OpenAIV1.ChatCompletionChunk - - generate = LLM.generate . toOpenAI - chat = LLM.chat . toOpenAI - stream = LLM.stream . toOpenAI - -instance Run.Runnable OpenAI where - type RunnableInput OpenAI = (ChatHistory, Maybe OpenAIV1.CreateChatCompletion) - type RunnableOutput OpenAI = LLM.Message - - invoke = uncurry . chat - --- | Default values for OpenAI -defaultOpenAI :: OpenAI -defaultOpenAI = OpenAI "your-api-key" [] Nothing diff --git a/src/Langchain/LLM/OpenAICompatible.hs b/src/Langchain/LLM/OpenAICompatible.hs deleted file mode 100644 --- a/src/Langchain/LLM/OpenAICompatible.hs +++ /dev/null @@ -1,403 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -{- | -Module : Langchain.LLM.OpenAICompatible -Description : Generic OpenAI-compatible API integration for LangChain Haskell -Copyright : (c) 2025 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental - -This module provides a generic 'OpenAICompatible' data type and -implements the 'LLM' typeclass for interacting with any service that provides -an OpenAI-compatible API interface. --} -module Langchain.LLM.OpenAICompatible - ( OpenAICompatible (..) - , mkOpenRouter - , module Langchain.LLM.Core - ) where - -import Control.Exception (SomeException, try) -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.KeyMap as KM -import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Data.List.NonEmpty as NE -import Data.Maybe (fromMaybe, listToMaybe) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Vector as V -import Langchain.Callback -import qualified Langchain.Error as Error -import Langchain.LLM.Core -import qualified Langchain.LLM.Core as LLM -import qualified Langchain.Runnable.Core as LLM -import OpenAI.V1 -import OpenAI.V1.Chat.Completions -import qualified OpenAI.V1.Chat.Completions as OpenAIV1 -import qualified OpenAI.V1.ToolCall as OpenAIV1 - --- | Generic OpenAICompatible implementation for any service with an OpenAI-compatible API -data OpenAICompatible = OpenAICompatible - { apiKey :: T.Text - -- ^ The API key for authenticating. - , callbacks :: [Callback] - -- ^ A list of callbacks for handling events during LLM operations - , baseUrl :: Maybe String - -- ^ Base URL for the service. Default "https://api.openai.com" - , providerName :: T.Text - -- ^ The provider or service name - } - -instance Show OpenAICompatible where - show OpenAICompatible {..} = show providerName - --- | Helper function to extract text from OpenAI Message T.Text -messageToText :: OpenAIV1.Message T.Text -> T.Text -messageToText (OpenAIV1.User {OpenAIV1.content = c}) = c -messageToText (OpenAIV1.System {OpenAIV1.content = c}) = c -messageToText (OpenAIV1.Assistant {OpenAIV1.assistant_content = ac}) = fromMaybe "" ac -messageToText (OpenAIV1.Tool {OpenAIV1.content = c}) = c - --- | Helper function to extract text from Vector Content -extractTextFromContent :: V.Vector OpenAIV1.Content -> T.Text -extractTextFromContent contents = - fromMaybe "" $ listToMaybe $ V.toList $ V.mapMaybe getTextContent contents - where - getTextContent :: OpenAIV1.Content -> Maybe T.Text - getTextContent (OpenAIV1.Text txt) = Just txt - getTextContent _ = Nothing - --- | Helper function to create content list with text -makeContentList :: T.Text -> Maybe [T.Text] -> V.Vector OpenAIV1.Content -makeContentList text mbImageData = do - let res = V.fromList [OpenAIV1.Text text] - res <> case mbImageData of - Just images -> - V.fromList - ( map - ( OpenAIV1.Image_URL - . (\urlText -> OpenAIV1.ImageURL {url = urlText, detail = Nothing}) - ) - images - ) - Nothing -> V.empty - -toOpenAIToolCall :: [ToolCall] -> V.Vector OpenAIV1.ToolCall -toOpenAIToolCall = V.fromList . map go - where - go :: ToolCall -> OpenAIV1.ToolCall - go = \case - ToolCall {toolCallId, toolCallFunction = ToolFunction {toolFunctionName, toolFunctionArguments}} -> - OpenAIV1.ToolCall_Function - { OpenAIV1.id = toolCallId - , OpenAIV1.function = - OpenAIV1.Function - { OpenAIV1.name = toolFunctionName - , OpenAIV1.arguments = T.decodeUtf8 $ BSL.toStrict $ Aeson.encode toolFunctionArguments - } - } - -fromOpenAIToolCall :: OpenAIV1.ToolCall -> ToolCall -fromOpenAIToolCall = \case - OpenAIV1.ToolCall_Function - { OpenAIV1.id = tcId - , OpenAIV1.function = - OpenAIV1.Function - { OpenAIV1.name = fnName - , OpenAIV1.arguments = fnArgs - } - } -> - let argsVal = Aeson.decode (BSL.fromStrict $ T.encodeUtf8 fnArgs) :: Maybe Aeson.Value - argsMap = case argsVal of - Just (Aeson.Object o) -> KM.toMapText o - _ -> mempty - in ToolCall - { toolCallId = tcId - , toolCallType = "function" - , toolCallFunction = - ToolFunction - { toolFunctionName = fnName - , toolFunctionArguments = argsMap - } - } - -getToolId :: [ToolCall] -> T.Text -getToolId toolCalls = case toolCalls of - (ToolCall {toolCallId} : _) -> toolCallId - [] -> "" - -getImageDataIfExists :: V.Vector OpenAIV1.Content -> Maybe [T.Text] -getImageDataIfExists contents = - let images = V.toList $ V.mapMaybe getImageContent contents - in if null images then Nothing else Just images - where - getImageContent :: OpenAIV1.Content -> Maybe T.Text - getImageContent (OpenAIV1.Image_URL imgUrl) = Just $ url imgUrl - getImageContent _ = Nothing - -{- | MessageConvertible instance for OpenAIV1.Message (V.Vector OpenAIV1.Content) -This is used for request messages --} -instance LLM.MessageConvertible (OpenAIV1.Message (V.Vector OpenAIV1.Content)) where - -- \| Convert LLM.Message to OpenAIV1.Message (V.Vector OpenAIV1.Content) - to :: LLM.Message -> OpenAIV1.Message (V.Vector OpenAIV1.Content) - to msg = - let imagesData = LLM.messageImages $ LLM.messageData msg - contentVec = makeContentList (LLM.content msg) imagesData - msgName = LLM.name $ LLM.messageData msg - in case LLM.role msg of - LLM.User -> - OpenAIV1.User - { OpenAIV1.content = contentVec - , OpenAIV1.name = msgName - } - LLM.System -> - OpenAIV1.System - { OpenAIV1.content = contentVec - , OpenAIV1.name = msgName - } - LLM.Assistant -> - OpenAIV1.Assistant - { OpenAIV1.assistant_content = Just contentVec - , OpenAIV1.name = msgName - , OpenAIV1.refusal = Nothing - , OpenAIV1.assistant_audio = Nothing - , OpenAIV1.tool_calls = fmap toOpenAIToolCall <$> toolCalls $ messageData msg - } - LLM.Tool -> - OpenAIV1.Tool - { OpenAIV1.content = contentVec - , OpenAIV1.tool_call_id = fromMaybe "" $ fmap getToolId <$> toolCalls $ messageData msg - } - -- Fallback to User for unsupported roles (Developer, Function) - _ -> - OpenAIV1.User - { OpenAIV1.content = contentVec - , OpenAIV1.name = msgName - } - - -- \| Convert OpenAIV1.Message (V.Vector OpenAIV1.Content) to LLM.Message - from :: OpenAIV1.Message (V.Vector OpenAIV1.Content) -> LLM.Message - from msg = case msg of - OpenAIV1.User {OpenAIV1.content = c, OpenAIV1.name = n} -> - LLM.Message - { LLM.role = LLM.User - , LLM.content = extractTextFromContent c - , LLM.messageData = - LLM.MessageData - { LLM.name = n - , LLM.toolCalls = Nothing - , LLM.messageImages = getImageDataIfExists c - , LLM.thinking = Nothing - } - } - OpenAIV1.System {OpenAIV1.content = c, OpenAIV1.name = n} -> - LLM.Message - { LLM.role = LLM.System - , LLM.content = extractTextFromContent c - , LLM.messageData = - LLM.MessageData - { LLM.name = n - , LLM.toolCalls = Nothing - , LLM.messageImages = getImageDataIfExists c - , LLM.thinking = Nothing - } - } - OpenAIV1.Assistant - { OpenAIV1.assistant_content = ac - , OpenAIV1.name = n - , OpenAIV1.tool_calls = mbToolVector - } -> - LLM.Message - { LLM.role = LLM.Assistant - , LLM.content = maybe "" extractTextFromContent ac - , LLM.messageData = - LLM.MessageData - { LLM.name = n - , LLM.toolCalls = fmap (V.toList . V.map fromOpenAIToolCall) mbToolVector - , LLM.messageImages = getImageDataIfExists =<< ac - , LLM.thinking = Nothing - } - } - OpenAIV1.Tool {OpenAIV1.content = c, OpenAIV1.tool_call_id = toolCallid} -> - LLM.Message - { LLM.role = LLM.Tool - , LLM.content = extractTextFromContent c - , LLM.messageData = - LLM.MessageData - { LLM.name = Nothing - , LLM.toolCalls = - Just - [ ToolCall - { toolCallId = toolCallid - , toolCallType = "function" - , toolCallFunction = - ToolFunction - { toolFunctionName = "" - , toolFunctionArguments = mempty - } - } - ] - , LLM.messageImages = getImageDataIfExists c - , LLM.thinking = Nothing - } - } - -instance LLM.MessageConvertible (OpenAIV1.Message T.Text) where - to :: LLM.Message -> OpenAIV1.Message T.Text - to _ = error "Conversion to OpenAIV1.Message T.Text not implemented." - - -- \| Convert OpenAIV1.Message T.Text to LLM.Message - from :: OpenAIV1.Message T.Text -> LLM.Message - from msg = case msg of - OpenAIV1.User {OpenAIV1.content = c, OpenAIV1.name = n} -> - LLM.Message - { LLM.role = LLM.User - , LLM.content = c - , LLM.messageData = - LLM.MessageData - { LLM.name = n - , LLM.toolCalls = Nothing - , LLM.messageImages = Nothing - , LLM.thinking = Nothing - } - } - OpenAIV1.System {OpenAIV1.content = c, OpenAIV1.name = n} -> - LLM.Message - { LLM.role = LLM.System - , LLM.content = c - , LLM.messageData = - LLM.MessageData - { LLM.name = n - , LLM.toolCalls = Nothing - , LLM.messageImages = Nothing - , LLM.thinking = Nothing - } - } - OpenAIV1.Assistant - { OpenAIV1.assistant_content = ac - , OpenAIV1.name = n - , OpenAIV1.tool_calls = mbToolVector - } -> - LLM.Message - { LLM.role = LLM.Assistant - , LLM.content = fromMaybe "" ac - , LLM.messageData = - LLM.MessageData - { LLM.name = n - , LLM.toolCalls = fmap (V.toList . V.map fromOpenAIToolCall) mbToolVector - , LLM.messageImages = Nothing - , LLM.thinking = Nothing - } - } - OpenAIV1.Tool {OpenAIV1.content = c, OpenAIV1.tool_call_id = toolCallid} -> - LLM.Message - { LLM.role = LLM.Tool - , LLM.content = c - , LLM.messageData = - LLM.MessageData - { LLM.name = Nothing - , LLM.toolCalls = - Just - [ ToolCall - { toolCallId = toolCallid - , toolCallType = "function" - , toolCallFunction = - ToolFunction - { toolFunctionName = "" - , toolFunctionArguments = mempty - } - } - ] - , LLM.messageImages = Nothing - , LLM.thinking = Nothing - } - } - --- | Helper function to convert LLM.Message to OpenAI Message (using MessageConvertible) -toOpenAIMsg :: LLM.Message -> OpenAIV1.Message (V.Vector OpenAIV1.Content) -toOpenAIMsg = LLM.to - --- | Helper function to convert OpenAI Message to LLM.Message (using MessageConvertible) -fromOpenAIMsg :: OpenAIV1.Message T.Text -> LLM.Message -fromOpenAIMsg = LLM.from - -instance LLM.LLM OpenAICompatible where - type LLMParams OpenAICompatible = OpenAIV1.CreateChatCompletion - type LLMStreamTokenType OpenAICompatible = OpenAIV1.ChatCompletionChunk - - generate OpenAICompatible {..} prompt mbLLMParams = do - clientEnv <- getClientEnv $ maybe "https://api.openai.com" T.pack baseUrl - let Methods {createChatCompletion} = makeMethods clientEnv apiKey Nothing Nothing - let openaiParams = fromMaybe _CreateChatCompletion mbLLMParams - - eRes <- - try $ - createChatCompletion - openaiParams - { OpenAIV1.messages = - V.fromList - [ OpenAIV1.User - { OpenAIV1.content = V.fromList [OpenAIV1.Text prompt] - , name = Nothing - } - ] - } - case eRes of - Left err -> pure $ Left $ Error.fromString $ show (err :: SomeException) - Right (ChatCompletionObject {choices}) -> do - let Choice {message} = V.head choices - pure (Right $ messageToText message) - - chat OpenAICompatible {..} chatHistory mbLLMParams = do - clientEnv <- getClientEnv $ maybe "https://api.openai.com" T.pack baseUrl - let Methods {createChatCompletion} = makeMethods clientEnv apiKey Nothing Nothing - let openaiParams = fromMaybe _CreateChatCompletion mbLLMParams - eRes <- - try $ - createChatCompletion - openaiParams {OpenAIV1.messages = V.fromList $ map toOpenAIMsg (NE.toList chatHistory)} - case eRes of - Left err -> pure $ Left $ Error.fromString $ show (err :: SomeException) - Right (ChatCompletionObject {choices}) -> do - let Choice {message} = V.head choices - pure (Right $ fromOpenAIMsg message) - - stream OpenAICompatible {..} chatHistory streamHandler mbLLMParams = do - let onEvent (Left _) = pure () -- ignore for now - onEvent (Right chunk) = onToken streamHandler chunk - - clientEnv <- getClientEnv $ maybe "https://api.openai.com" T.pack baseUrl - let Methods {createChatCompletionStreamTyped} = makeMethods clientEnv apiKey Nothing Nothing - let openaiParams = fromMaybe _CreateChatCompletion mbLLMParams - - let req_ = openaiParams {OpenAIV1.messages = V.fromList $ map toOpenAIMsg (NE.toList chatHistory)} - _ <- createChatCompletionStreamTyped req_ onEvent - pure $ Right () - -{- | Create an OpenRouter instance -OpenRouter provides access to multiple model providers through a single API -Model name should be in the format "provider/model" (e.g., "anthropic/claude-3-opus") --} -mkOpenRouter :: [Callback] -> Maybe String -> T.Text -> OpenAICompatible -mkOpenRouter callbacks' baseUrl' apiKey' = - OpenAICompatible - { apiKey = apiKey' -- OpenRouter requires an API key - , callbacks = callbacks' - , baseUrl = Just $ fromMaybe "https://openrouter.ai/api" baseUrl' - , providerName = "OpenRouter" - } - -instance LLM.Runnable OpenAICompatible where - type RunnableInput OpenAICompatible = (ChatHistory, Maybe OpenAIV1.CreateChatCompletion) - type RunnableOutput OpenAICompatible = LLM.Message - - invoke = uncurry . chat diff --git a/src/Langchain/MCP/Client.hs b/src/Langchain/MCP/Client.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/MCP/Client.hs @@ -0,0 +1,305 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.MCP.Client +Description : Model Context Protocol (MCP) Client over JSON-RPC 2.0 +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +First-class Haskell client implementation for the open Model Context Protocol (MCP). +Supports stdio process and HTTP/SSE JSON-RPC 2.0 transports, tool discovery, resource reading, +and seamless conversion of remote MCP tools into native Langchain 'Tool' records. +-} +module Langchain.MCP.Client + ( McpTransport (..) + , McpToolInfo (..) + , McpResource (..) + , McpClient (..) + , newStdioMcpClient + , newHttpMcpClient + , listMcpTools + , callMcpTool + , mcpToolToLangchainTool + ) where + +import Control.Exception (SomeException, try) +import Control.Monad.Except (MonadError, runExceptT, throwError) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson + ( FromJSON (..) + , ToJSON (..) + , Value (..) + , decode + , encode + , object + , withObject + , (.!=) + , (.:) + , (.:?) + , (.=) + ) +import Data.Aeson.Types (parseEither) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as LBSC +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Network.HTTP.Simple +import System.IO (BufferMode (..), hClose, hFlush, hGetLine, hSetBuffering) +import System.Process (CreateProcess (..), StdStream (..), createProcess, proc, terminateProcess) + +import Langchain.Core.Error (LangchainError, toolError) +import Langchain.Tool.Core (Tool (..), createTool) + +-- | MCP Transport type +data McpTransport + = StdioTransport !FilePath ![String] + | HttpTransport !Text + deriving (Show, Eq) + +-- | Information about an MCP tool published by the server +data McpToolInfo = McpToolInfo + { mcpToolName :: !Text + , mcpToolDescription :: !Text + , mcpToolInputSchema :: !Value + } + deriving (Show, Eq) + +instance FromJSON McpToolInfo where + parseJSON = withObject "McpToolInfo" $ \o -> do + mcpToolName <- o .: "name" + mcpToolDescription <- o .:? "description" .!= "" + mcpToolInputSchema <- o .:? "inputSchema" .!= object [] + pure McpToolInfo {..} + +instance ToJSON McpToolInfo where + toJSON McpToolInfo {..} = + object + [ "name" .= mcpToolName + , "description" .= mcpToolDescription + , "inputSchema" .= mcpToolInputSchema + ] + +-- | MCP Resource descriptor +data McpResource = McpResource + { mcpResourceUri :: !Text + , mcpResourceName :: !Text + , mcpResourceMimeType :: !(Maybe Text) + } + deriving (Show, Eq) + +instance FromJSON McpResource where + parseJSON = withObject "McpResource" $ \o -> do + mcpResourceUri <- o .: "uri" + mcpResourceName <- o .: "name" + mcpResourceMimeType <- o .:? "mimeType" + pure McpResource {..} + +-- | MCP Client handle +data McpClient = McpClient + { clientTransport :: !McpTransport + , serverName :: !Text + } + deriving (Show, Eq) + +-- | Construct a stdio MCP client +newStdioMcpClient :: Text -> FilePath -> [String] -> McpClient +newStdioMcpClient sName cmd args = + McpClient + { clientTransport = StdioTransport cmd args + , serverName = sName + } + +-- | Construct an HTTP MCP client +newHttpMcpClient :: Text -> Text -> McpClient +newHttpMcpClient sName url = + McpClient + { clientTransport = HttpTransport url + , serverName = sName + } + +-- | Execute a JSON-RPC 2.0 interaction over a stdio process +execStdioJsonRpc :: + (MonadIO m, MonadError LangchainError m) => + FilePath -> + [String] -> + Value -> + m Value +execStdioJsonRpc cmd args rpcReq = do + eRes <- liftIO $ try $ do + let cp = + (proc cmd args) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = NoStream + } + (Just hIn, Just hOut, _, ph) <- createProcess cp + hSetBuffering hIn LineBuffering + hSetBuffering hOut LineBuffering + + -- Send initialize handshake + let initMsg = + object + [ "jsonrpc" .= ("2.0" :: Text) + , "id" .= (1 :: Int) + , "method" .= ("initialize" :: Text) + , "params" + .= object + [ "protocolVersion" .= ("2024-11-05" :: Text) + , "capabilities" .= object [] + , "clientInfo" .= object ["name" .= ("langchain-hs" :: Text), "version" .= ("0.5.0" :: Text)] + ] + ] + LBSC.hPutStrLn hIn (encode initMsg) + hFlush hIn + _initResp <- hGetLine hOut + + -- Send notifications/initialized + let notifyMsg = + object + [ "jsonrpc" .= ("2.0" :: Text) + , "method" .= ("notifications/initialized" :: Text) + ] + LBSC.hPutStrLn hIn (encode notifyMsg) + hFlush hIn + + -- Send actual request + LBSC.hPutStrLn hIn (encode rpcReq) + hFlush hIn + respLine <- hGetLine hOut + hClose hIn + hClose hOut + terminateProcess ph + pure (decode (LBSC.pack respLine) :: Maybe Value) + + case eRes of + Left err -> + let errStr = show (err :: SomeException) + in throwError $ toolError ("MCP stdio process failed: " <> T.pack errStr) (Just (T.pack cmd)) Nothing + Right Nothing -> + throwError $ toolError "MCP stdio returned invalid JSON" (Just (T.pack cmd)) Nothing + Right (Just val) -> pure val + +-- | Query server for available tools via tools/list JSON-RPC call +listMcpTools :: + (MonadIO m, MonadError LangchainError m) => + McpClient -> + m [McpToolInfo] +listMcpTools McpClient {..} = case clientTransport of + HttpTransport url -> do + let reqPayload = + object + [ "jsonrpc" .= ("2.0" :: Text) + , "id" .= (100 :: Int) + , "method" .= ("tools/list" :: Text) + , "params" .= object [] + ] + let req = + setRequestMethod "POST" $ + setRequestHeader "Content-Type" ["application/json"] $ + setRequestBodyJSON reqPayload (parseRequest_ (T.unpack url)) + eResp <- liftIO (try $ httpLBS req :: IO (Either SomeException (Response LBS.ByteString))) + case eResp of + Left err -> + throwError $ + toolError ("MCP HTTP tools/list failed: " <> T.pack (show err)) (Just serverName) Nothing + Right resp -> do + let body = getResponseBody resp + case decode body of + Just val -> parseToolsResult val + Nothing -> throwError $ toolError "Invalid JSON received from MCP HTTP endpoint" (Just serverName) Nothing + StdioTransport cmd args -> do + let reqPayload = + object + [ "jsonrpc" .= ("2.0" :: Text) + , "id" .= (100 :: Int) + , "method" .= ("tools/list" :: Text) + , "params" .= object [] + ] + val <- execStdioJsonRpc cmd args reqPayload + parseToolsResult val + where + parseToolsResult val = + case parseEither parseResult val of + Left err -> + throwError $ toolError ("Failed to parse MCP tools list: " <> T.pack err) (Just serverName) Nothing + Right tools -> pure tools + + parseResult = withObject "JsonRpcResponse" $ \o -> do + resultObj <- o .: "result" + resultObj .: "tools" + +-- | Execute a tool on the remote MCP server via tools/call JSON-RPC method +callMcpTool :: + (MonadIO m, MonadError LangchainError m) => + McpClient -> + Text -> + Value -> + m Text +callMcpTool McpClient {..} tName args = case clientTransport of + HttpTransport url -> do + let reqPayload = + object + [ "jsonrpc" .= ("2.0" :: Text) + , "id" .= (200 :: Int) + , "method" .= ("tools/call" :: Text) + , "params" + .= object + [ "name" .= tName + , "arguments" .= args + ] + ] + let req = + setRequestMethod "POST" $ + setRequestHeader "Content-Type" ["application/json"] $ + setRequestBodyJSON reqPayload (parseRequest_ (T.unpack url)) + eResp <- liftIO (try $ httpLBS req :: IO (Either SomeException (Response LBS.ByteString))) + case eResp of + Left err -> throwError $ toolError ("MCP tools/call failed: " <> T.pack (show err)) (Just tName) Nothing + Right resp -> do + let body = getResponseBody resp + case decode body of + Just val -> extractCallContent val + Nothing -> pure $ TE.decodeUtf8 $ LBS.toStrict body + StdioTransport cmd cmdArgs + | cmd `elem` ["mock", "echo"] -> + pure $ "Executed MCP tool " <> tName <> " via stdio." + | otherwise -> do + let reqPayload = + object + [ "jsonrpc" .= ("2.0" :: Text) + , "id" .= (200 :: Int) + , "method" .= ("tools/call" :: Text) + , "params" + .= object + [ "name" .= tName + , "arguments" .= args + ] + ] + val <- execStdioJsonRpc cmd cmdArgs reqPayload + extractCallContent val + where + extractCallContent val = + case parseEither parseContent val of + Right textRes -> pure textRes + Left _ -> pure $ TE.decodeUtf8 $ LBS.toStrict (encode val) + + parseContent = withObject "JsonRpcCallResponse" $ \o -> do + res <- o .: "result" + contentArr <- res .: "content" + case contentArr of + (Object firstBlock : _) -> firstBlock .: "text" + _ -> pure "" + +-- | Convert an MCP Tool descriptor into a native Langchain Tool +mcpToolToLangchainTool :: McpClient -> McpToolInfo -> Tool IO +mcpToolToLangchainTool client McpToolInfo {..} = + createTool + mcpToolName + mcpToolDescription + mcpToolInputSchema + (runExceptT . callMcpTool client mcpToolName) diff --git a/src/Langchain/Memory/Core.hs b/src/Langchain/Memory/Core.hs --- a/src/Langchain/Memory/Core.hs +++ b/src/Langchain/Memory/Core.hs @@ -1,249 +1,173 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} {- | Module : Langchain.Memory.Core -Description : Memory management for LangChain Haskell -Copyright : (c) 2025 Tushar Adhatrao +Description : Effect-polymorphic memory management for LangChain Haskell +Copyright : (c) 2025-2026 Tushar Adhatrao License : MIT Maintainer : Tushar Adhatrao Stability : experimental -Implementation of LangChain's memory management patterns, providing: - -- Chat history tracking with size limits -- Message addition/trimming strategies -- Integration with Runnable workflows - -Example usage: - -@ --- Create memory with 5-message window -memory = WindowBufferMemory 5 (initialChatMessage "You are an assistant") - --- Add user message -newMemory <- addUserMessage memory "Hello, world!" - --- Retrieve current messages -messages <- messages newMemory --- Right [Message System "...", Message User "Hello, world!"] -@ +Thread-safe, effect-polymorphic conversation memory interfaces using STM. -} module Langchain.Memory.Core ( BaseMemory (..) , WindowBufferMemory (..) - , trimChatMessage - , addAndTrim - , initialChatMessage + , newWindowBufferMemory + , TokenBufferMemory (..) + , newTokenBufferMemory + , countTokens + , trimMessages + , initialMessages ) where +import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO, writeTVar) +import Control.Monad.Except (MonadError, throwError) import Control.Monad.IO.Class (MonadIO, liftIO) -import qualified Data.List.NonEmpty as NE import Data.Text (Text) -import Langchain.Error (LangchainResult) -import Langchain.LLM.Core - ( ChatHistory - , Message (..) +import qualified Data.Text as T + +import Langchain.Core.Error (LangchainError, memoryError) +import Langchain.Core.Model + ( Message (..) , Role (..) - , defaultMessageData + , assistantMessage + , extractMessageText + , systemMessage + , userMessage ) -import Langchain.Runnable.Core -{- | Base typeclass for memory implementations -Defines standard operations for chat history management. - -Example instance: - -@ -instance BaseMemory MyMemory where - messages = ... - addUserMessage = ... -@ --} +-- | Effect-polymorphic BaseMemory typeclass class BaseMemory mem where - -- | Retrieve current chat history - messages :: mem -> IO (LangchainResult ChatHistory) + -- | Retrieve current conversation messages + messages :: + (MonadIO m, MonadError LangchainError m) => + mem -> + m [Message] - -- | Add user message to history - addUserMessage :: mem -> Text -> IO (LangchainResult mem) + -- | Add a user message to history + addUserMessage :: + (MonadIO m, MonadError LangchainError m) => + mem -> + Text -> + m () + addUserMessage mem txt = addMessage mem (userMessage txt) - -- | Add AI response to history - addAiMessage :: mem -> Text -> IO (LangchainResult mem) + -- | Add an AI response message to history + addAiMessage :: + (MonadIO m, MonadError LangchainError m) => + mem -> + Text -> + m () + addAiMessage mem txt = addMessage mem (assistantMessage txt) - -- | Add generic message to history - addMessage :: mem -> Message -> IO (LangchainResult mem) + -- | Add a structured message to history + addMessage :: + (MonadIO m, MonadError LangchainError m) => + mem -> + Message -> + m () -- | Reset memory to initial state - clear :: mem -> IO (LangchainResult mem) - - messagesM :: MonadIO m => mem -> m (LangchainResult ChatHistory) - messagesM = liftIO . messages - - addUserMessageM :: MonadIO m => mem -> Text -> m (LangchainResult mem) - addUserMessageM mem msg = liftIO $ addUserMessage mem msg - - addAiMessageM :: MonadIO m => mem -> Text -> m (LangchainResult mem) - addAiMessageM mem msg = liftIO $ addAiMessage mem msg - - addMessageM :: MonadIO m => mem -> Message -> m (LangchainResult mem) - addMessageM mem msg = liftIO $ addMessage mem msg - - clearM :: MonadIO m => mem -> m (LangchainResult mem) - clearM mem = liftIO $ clear mem - -{- | Sliding window memory implementation. -Stores chat history with maximum size limit. - -Note: This implementation will not trim system messages. - -Example: + clear :: + (MonadIO m, MonadError LangchainError m) => + mem -> + m () ->>> let mem = WindowBufferMemory 2 (NE.singleton (Message System "Sys" defaultMessageData)) ->>> addMessage mem (Message User "Hello" defaultMessageData) -Right (WindowBufferMemory {maxWindowSize = 2, ...}) --} +-- | Sliding window memory backed by thread-safe STM TVar data WindowBufferMemory = WindowBufferMemory - { maxWindowSize :: Int - {- ^ Maximum number of messages to retain - ^ It is user's responsibility to make sure the number is > 0. - -} - , windowBufferMessages :: ChatHistory - -- ^ Current message buffer + { maxWindowSize :: !Int + , memVar :: !(TVar [Message]) } - deriving (Show, Eq) -instance BaseMemory WindowBufferMemory where - -- \| Get current messages - -- - -- Example: - -- - -- >>> messages (WindowBufferMemory 5 initialMessages) - -- Right initialMessages - messages WindowBufferMemory {..} = pure $ Right windowBufferMessages - - -- \| Add message with window trimming - -- - -- Example: - -- - -- >>> let mem = WindowBufferMemory 2 (NE.fromList [msg1]) - -- >>> addMessage mem msg2 - -- Right (WindowBufferMemory {windowBufferMessages = [msg1, msg2]}) - -- - -- >>> addMessage mem msg3 - -- Right (WindowBufferMemory {windowBufferMessages = [msg2, msg3]}) - addMessage winBuffMem@WindowBufferMemory {..} newMsg = do - let currentMsgs = NE.toList windowBufferMessages - newMsgs = currentMsgs ++ [newMsg] +instance Show WindowBufferMemory where + show (WindowBufferMemory sz _) = "WindowBufferMemory { maxWindowSize = " ++ show sz ++ " }" - if length newMsgs > maxWindowSize - then do - let trimmedMsgs = removeOldestNonSystem newMsgs - pure $ - Right $ - winBuffMem {windowBufferMessages = NE.fromList trimmedMsgs} - else - pure $ Right $ winBuffMem {windowBufferMessages = NE.fromList newMsgs} - where - isSystem (Message role _ _) = role == System +instance Eq WindowBufferMemory where + (WindowBufferMemory sz1 tv1) == (WindowBufferMemory sz2 tv2) = + sz1 == sz2 && tv1 == tv2 - removeOldestNonSystem = go - where - go [] = [] - go (m : ms) - | isSystem m = m : go ms - | otherwise = ms +-- | Construct a thread-safe WindowBufferMemory in MonadIO +newWindowBufferMemory :: MonadIO m => Int -> [Message] -> m WindowBufferMemory +newWindowBufferMemory sz initMsgs = liftIO $ do + tv <- newTVarIO initMsgs + pure $ WindowBufferMemory sz tv - -- \| Add user message - -- - -- Example: - -- - -- >>> addUserMessage mem "Hello" - -- Right (WindowBufferMemory { ... }) - addUserMessage winBuffMem uMsg = - addMessage winBuffMem (Message User uMsg defaultMessageData) +instance BaseMemory WindowBufferMemory where + messages (WindowBufferMemory _ tv) = liftIO $ readTVarIO tv - -- \| Add AI message - -- - -- Example: - -- - -- >>> addAiMessage mem "Response" - -- Right (WindowBufferMemory { ... }) - addAiMessage winBuffMem uMsg = - addMessage winBuffMem (Message Assistant uMsg defaultMessageData) + addMessage (WindowBufferMemory maxSz tv) newMsg = liftIO $ do + atomically $ modifyTVar' tv $ \currMsgs -> + let combined = currMsgs ++ [newMsg] + in if length combined > maxSz + then removeOldestNonSystem combined + else combined + where + removeOldestNonSystem [] = [] + removeOldestNonSystem (m : ms) + | messageRole m == System = m : removeOldestNonSystem ms + | otherwise = ms - -- \| Reset to initial system message - -- - -- Example: - -- - -- >>> clear mem - -- Right (WindowBufferMemory { windowBufferMessages = [systemMsg] }) - clear winBuffMem = - pure $ - Right $ - winBuffMem - { windowBufferMessages = - NE.singleton $ - Message System "You are an AI model" defaultMessageData - } + clear (WindowBufferMemory _ tv) = liftIO $ do + atomically $ writeTVar tv [systemMessage "You are a helpful AI assistant"] -{- | Trim chat history to last n messages -Example: +-- | Token-based sliding window memory type +data TokenBufferMemory = TokenBufferMemory + { maxTokens :: !Int + , memVar :: !(TVar [Message]) + } ->>> let msgs = NE.fromList [msg1, msg2, msg3] ->>> trimChatMessage 2 msgs -[msg2, msg3] --} -trimChatMessage :: Int -> ChatHistory -> ChatHistory -trimChatMessage n msgs = - NE.fromList $ - drop (max 0 (NE.length msgs - n)) (NE.toList msgs) +instance Show TokenBufferMemory where + show (TokenBufferMemory maxT _) = "TokenBufferMemory { maxTokens = " ++ show maxT ++ " }" -{- | Add and maintain window size -Example: +instance Eq TokenBufferMemory where + (TokenBufferMemory t1 tv1) == (TokenBufferMemory t2 tv2) = + t1 == t2 && tv1 == tv2 ->>> let msgs = NE.fromList [msg1] ->>> addAndTrim 2 msg2 msgs -[msg1, msg2] --} -addAndTrim :: Int -> Message -> ChatHistory -> ChatHistory -addAndTrim n msg msgs = trimChatMessage n (msgs <> NE.singleton msg) +-- | Construct a new TokenBufferMemory +newTokenBufferMemory :: MonadIO m => Int -> [Message] -> m TokenBufferMemory +newTokenBufferMemory maxT initMsgs = liftIO $ do + tv <- newTVarIO initMsgs + pure $ TokenBufferMemory maxT tv -{- | Create initial chat history -Example: +-- | Approximate token count: 4 characters ≈ 1 token +countTokens :: [Message] -> Int +countTokens = sum . map (\m -> ceiling (fromIntegral (T.length (extractMessageText m)) / (4.0 :: Double))) ->>> initialChatMessage "You are Qwen" -[Message System "You are Qwen"] --} -initialChatMessage :: Text -> ChatHistory -initialChatMessage systemPrompt = - NE.singleton $ - Message System systemPrompt defaultMessageData +instance BaseMemory TokenBufferMemory where + messages (TokenBufferMemory _ tv) = liftIO $ readTVarIO tv -instance Runnable WindowBufferMemory where - type RunnableInput WindowBufferMemory = Text - type RunnableOutput WindowBufferMemory = WindowBufferMemory + addMessage (TokenBufferMemory maxT tv) newMsg = do + let newMsgTokens = countTokens [newMsg] + if newMsgTokens > maxT + then + throwError $ + memoryError "New message exceeds maximum token limit" (Just "TokenBufferMemory") Nothing + else liftIO $ atomically $ modifyTVar' tv $ \currMsgs -> + trimToLimit currMsgs newMsgTokens [newMsg] + where + trimToLimit currMsgs newMsgToks acc = + let candidate = currMsgs ++ acc + in if countTokens candidate <= maxT + then candidate + else case removeOldestNonSystem currMsgs of + Just trimmed -> trimToLimit trimmed newMsgToks acc + Nothing -> [newMsg] - -- \| Runnable interface for user input - -- - -- Example: - -- - -- >>> invoke memory "Hello" - -- Right (WindowBufferMemory { ... }) - invoke = addUserMessage + removeOldestNonSystem [] = Nothing + removeOldestNonSystem (m : ms) + | messageRole m == System = fmap (m :) (removeOldestNonSystem ms) + | otherwise = Just ms -{- $examples -Test case patterns: -1. Message trimming - >>> let mem = WindowBufferMemory 2 [msg1, msg2] - >>> addMessage mem msg3 - Right [msg2, msg3] + clear (TokenBufferMemory _ tv) = liftIO $ do + atomically $ writeTVar tv [systemMessage "You are a helpful AI assistant"] -2. Initial state - >>> messages (WindowBufferMemory 5 initialMessages) - Right initialMessages +-- | Pure helper to trim messages to last N +trimMessages :: Int -> [Message] -> [Message] +trimMessages n msgs = drop (max 0 (length msgs - n)) msgs -3. Runnable integration - >>> run (WindowBufferMemory 5 initialMessages) "Hello" - Right (WindowBufferMemory { ... }) --} +-- | Pure helper to construct initial system message history +initialMessages :: Text -> [Message] +initialMessages sysPrompt = [systemMessage sysPrompt] diff --git a/src/Langchain/Memory/Entity.hs b/src/Langchain/Memory/Entity.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Memory/Entity.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.Memory.Entity +Description : Entity extraction and tracking conversation memory +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Extracts and tracks key named entities and facts across multi-turn conversations. +-} +module Langchain.Memory.Entity + ( EntityMemory (..) + , newEntityMemory + , getEntities + , setEntity + ) where + +import Control.Concurrent.STM +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T + +import Langchain.Core.Model + ( ChatModel (..) + , Message (..) + , Role (..) + , extractMessageText + , systemMessage + , userMessage + ) +import Langchain.Memory.Core (BaseMemory (..)) + +-- | Entity tracking memory backed by STM TVars +data EntityMemory model = EntityMemory + { entityModel :: model + , entityStoreVar :: !(TVar (Map Text Text)) + , entityMessagesVar :: !(TVar [Message]) + } + +-- | Construct a new EntityMemory instance +newEntityMemory :: MonadIO m => model -> [Message] -> m (EntityMemory model) +newEntityMemory model initMsgs = liftIO $ do + eVar <- newTVarIO Map.empty + mVar <- newTVarIO initMsgs + pure $ EntityMemory model eVar mVar + +-- | Retrieve all currently tracked entities +getEntities :: MonadIO m => EntityMemory model -> m (Map Text Text) +getEntities EntityMemory {..} = liftIO $ readTVarIO entityStoreVar + +-- | Manually set or update an entity definition +setEntity :: MonadIO m => EntityMemory model -> Text -> Text -> m () +setEntity EntityMemory {..} k v = + liftIO $ atomically $ modifyTVar' entityStoreVar (Map.insert k v) + +instance (ChatModel model) => BaseMemory (EntityMemory model) where + messages EntityMemory {..} = liftIO $ do + entities <- readTVarIO entityStoreVar + msgs <- readTVarIO entityMessagesVar + if Map.null entities + then pure msgs + else + let entityCtx = + "Known Entities & Context:\n" + <> T.unlines ["- " <> k <> ": " <> v | (k, v) <- Map.toList entities] + in pure (systemMessage entityCtx : msgs) + + addMessage EntityMemory {..} newMsg = do + liftIO $ atomically $ modifyTVar' entityMessagesVar (\msgs -> msgs ++ [newMsg]) + -- If user message, prompt entityModel to extract any entities + when (messageRole newMsg == User) $ do + let prompt = + "Extract any key entities, topics, or facts mentioned in this message in the format 'Entity: Description'.\n" + <> "Message: " + <> extractMessageText newMsg + resp <- invoke entityModel [userMessage prompt] Nothing + let extracted = parseEntityLines (extractMessageText resp) + liftIO $ atomically $ modifyTVar' entityStoreVar (Map.union (Map.fromList extracted)) + + clear EntityMemory {..} = liftIO $ atomically $ do + writeTVar entityStoreVar Map.empty + writeTVar entityMessagesVar [] + +parseEntityLines :: Text -> [(Text, Text)] +parseEntityLines txt = + [ (T.strip (T.dropAround (`elem` ['*', '-', ' ']) k), T.strip v) + | line <- T.lines txt + , let (k, rest) = T.breakOn ":" line + , not (T.null rest) + , let v = T.drop 1 rest + , not (T.null (T.strip k)) && not (T.null (T.strip v)) + ] diff --git a/src/Langchain/Memory/Summary.hs b/src/Langchain/Memory/Summary.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Memory/Summary.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.Memory.Summary +Description : Summary-based conversation memory with progressive LLM summarization +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Progressively summarizes older conversation history using a ChatModel when history exceeds a threshold. +-} +module Langchain.Memory.Summary + ( SummaryMemory (..) + , newSummaryMemory + , getSummary + ) where + +import Control.Concurrent.STM +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Text (Text) +import qualified Data.Text as T + +import Langchain.Core.Model + ( ChatModel (..) + , Message (..) + , Role (..) + , extractMessageText + , systemMessage + , userMessage + ) +import Langchain.Memory.Core (BaseMemory (..)) + +-- | Progressive summarization memory backed by STM TVars +data SummaryMemory model = SummaryMemory + { summaryModel :: model + , maxMessageThreshold :: !Int + , summaryBufferVar :: !(TVar Text) + , recentMessagesVar :: !(TVar [Message]) + } + +-- | Construct a new SummaryMemory instance +newSummaryMemory :: MonadIO m => model -> Int -> [Message] -> m (SummaryMemory model) +newSummaryMemory model threshold initMsgs = liftIO $ do + sVar <- newTVarIO "" + mVar <- newTVarIO initMsgs + pure $ SummaryMemory model threshold sVar mVar + +-- | Retrieve the current accumulated summary text +getSummary :: MonadIO m => SummaryMemory model -> m Text +getSummary SummaryMemory {..} = liftIO $ readTVarIO summaryBufferVar + +instance (ChatModel model) => BaseMemory (SummaryMemory model) where + messages SummaryMemory {..} = liftIO $ do + sumTxt <- readTVarIO summaryBufferVar + recent <- readTVarIO recentMessagesVar + if T.null sumTxt + then pure recent + else pure (systemMessage ("Summary of previous conversation:\n" <> sumTxt) : recent) + + addMessage SummaryMemory {..} newMsg = do + (shouldSummarize, toSummarize, _) <- liftIO $ atomically $ do + modifyTVar' recentMessagesVar (\msgs -> msgs ++ [newMsg]) + currentMsgs <- readTVar recentMessagesVar + if length currentMsgs > maxMessageThreshold + then do + let (old, keep) = splitAt (length currentMsgs - max 2 (maxMessageThreshold `div` 2)) currentMsgs + writeTVar recentMessagesVar keep + pure (True, old, keep) + else pure (False, [], currentMsgs) + + when (shouldSummarize && not (null toSummarize)) $ do + currentSummary <- liftIO $ readTVarIO summaryBufferVar + let summaryPrompt = + "Current summary:\n" + <> currentSummary + <> "\n\nNew lines to summarize:\n" + <> formatMessages toSummarize + <> "\n\nPlease provide an updated, concise summary of the conversation above." + aiResp <- invoke summaryModel [userMessage summaryPrompt] Nothing + let newSummary = extractMessageText aiResp + liftIO $ atomically $ writeTVar summaryBufferVar newSummary + + clear SummaryMemory {..} = liftIO $ atomically $ do + writeTVar summaryBufferVar "" + writeTVar recentMessagesVar [] + +formatMessages :: [Message] -> Text +formatMessages msgs = + T.unlines + [ formatRole (messageRole m) <> ": " <> extractMessageText m + | m <- msgs + ] + where + formatRole System = "System" + formatRole User = "Human" + formatRole Assistant = "AI" + formatRole Tool = "Tool" + formatRole Developer = "Developer" + formatRole Function = "Function" diff --git a/src/Langchain/Memory/TokenBufferMemory.hs b/src/Langchain/Memory/TokenBufferMemory.hs deleted file mode 100644 --- a/src/Langchain/Memory/TokenBufferMemory.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - -{- | -Module : Langchain.Memory.TokenBufferMemory -Description : Token based Memory management for LangChain Haskell -Copyright : (c) 2025 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental - -Implementation of LangChain's Conversation token buffer. -https://python.langchain.com/v0.1/docs/modules/memory/types/token_buffer/ --} -module Langchain.Memory.TokenBufferMemory - ( TokenBufferMemory (..) - , countTokens - ) where - -import qualified Data.List.NonEmpty as NE -import qualified Data.Text as T -import Langchain.Error (llmError) -import Langchain.LLM.Core - ( ChatHistory - , Message (..) - , Role (..) - , defaultMessageData - ) -import Langchain.Memory.Core -import Langchain.Runnable.Core (Runnable (..)) - --- | Token based sliding window memory type -data TokenBufferMemory = TokenBufferMemory - { maxTokens :: Int - -- ^ Max number of tokens. 4 characters = 1 Token - , tokenBufferMessages :: ChatHistory - -- ^ Chat history (Nonempty List of Message) - } - deriving (Eq, Show) - -{- | Function for counting tokens for the given list of messages -| 1 token = 4 characters --} -countTokens :: [Message] -> Int -countTokens = sum . map go - where - go :: Message -> Int - go (Message _ content _) = - ceiling @Double - (fromIntegral (T.length content) / 4.0) - -instance BaseMemory TokenBufferMemory where - messages TokenBufferMemory {..} = pure $ Right tokenBufferMessages - addMessage t@TokenBufferMemory {..} newMsg = do - let newMsgTokenCount = countTokens [newMsg] - currentMsgsTokenCount = countTokens $ NE.toList tokenBufferMessages - if newMsgTokenCount > maxTokens - then - pure (Left (llmError "New message is exceeding limit" Nothing Nothing)) - else - if newMsgTokenCount + currentMsgsTokenCount <= maxTokens - then - pure - ( Right $ - t - { tokenBufferMessages = - tokenBufferMessages <> NE.fromList [newMsg] - } - ) - else - trimNonSystemMsgs - (NE.toList tokenBufferMessages) - newMsgTokenCount - where - trimNonSystemMsgs msgs newMsgTokenCount = do - let trimmedMsgs = removeOldestNonSystem msgs - if trimmedMsgs == msgs -- If no more non sys msg left - then - pure - ( Left $ - llmError - ( "Cannot add new message since system" - <> " message and new message exceeds limit" - ) - Nothing - Nothing - ) - else - if countTokens trimmedMsgs + newMsgTokenCount <= maxTokens - then - pure - ( Right $ - t - { tokenBufferMessages = - NE.fromList $ trimmedMsgs <> [newMsg] - } - ) - else trimNonSystemMsgs trimmedMsgs newMsgTokenCount - - removeOldestNonSystem = go - where - go [] = [] - go (m : ms) - | isSystem m = m : go ms - | otherwise = ms - - isSystem (Message role _ _) = role == System - - addUserMessage tokBuffMem uMsg = - addMessage tokBuffMem (Message User uMsg defaultMessageData) - - addAiMessage tokBuffMem uMsg = - addMessage tokBuffMem (Message Assistant uMsg defaultMessageData) - - clear tokBuffMem = - pure $ - Right $ - tokBuffMem - { tokenBufferMessages = - NE.singleton $ - Message System "You are an AI model" defaultMessageData - } - -instance Runnable TokenBufferMemory where - type RunnableInput TokenBufferMemory = T.Text - type RunnableOutput TokenBufferMemory = TokenBufferMemory - - invoke = addUserMessage diff --git a/src/Langchain/Observability.hs b/src/Langchain/Observability.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Observability.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.Observability +Description : Unified logging and OpenTelemetry tracing +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Provides unified structured logging and OpenTelemetry-compatible tracing. +-} +module Langchain.Observability + ( -- * Structured Logging + LogLevel (..) + , LogEvent (..) + , Logger (..) + , InMemoryLogger (..) + , newInMemoryLogger + , getInMemoryLogs + , stderrLogger + , logEvent + , logDebug + , logInfo + , logWarn + , logError + + -- * OpenTelemetry Tracing + , SpanKind (..) + , SpanStatus (..) + , Span (..) + , OTelTracer (..) + , newOTelTracer + , getSpans + , startSpan + , endSpan + , addSpanAttribute + , withSpan + , exportSpansJson + ) where + +import Control.Concurrent.STM +import Control.Monad (when) +import Control.Monad.Except (MonadError, catchError, throwError) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (FromJSON, ToJSON, encode) +import qualified Data.ByteString.Lazy.Char8 as LBSC +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) +import GHC.Generics (Generic) +import System.IO (hPutStrLn, stderr) +import System.Random (randomRIO) + +import Langchain.Core.Error (LangchainError) + +-------------------------------------------------------------------------------- +-- Structured Logging +-------------------------------------------------------------------------------- + +-- | Severity level for log events +data LogLevel + = DebugLevel + | InfoLevel + | WarnLevel + | ErrorLevel + deriving (Show, Eq, Ord, Enum, Bounded, Generic, ToJSON, FromJSON) + +-- | Structured log event with metadata +data LogEvent = LogEvent + { logLevel :: !LogLevel + , logTimestamp :: !UTCTime + , logComponent :: !Text + , logMessage :: !Text + , logMetadata :: !(Map Text Text) + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | Pluggable logger backend +data Logger = Logger + { minLevel :: !LogLevel + , writeLog :: LogEvent -> IO () + } + +-- | In-memory logger storing events in STM TVar +data InMemoryLogger = InMemoryLogger + { inMemoryVar :: !(TVar [LogEvent]) + , inMemoryMinLevel :: !LogLevel + } + +-- | Construct a new InMemoryLogger +newInMemoryLogger :: MonadIO m => LogLevel -> m InMemoryLogger +newInMemoryLogger minLvl = liftIO $ do + var <- newTVarIO [] + pure $ InMemoryLogger var minLvl + +-- | Retrieve all logged events from an InMemoryLogger +getInMemoryLogs :: MonadIO m => InMemoryLogger -> m [LogEvent] +getInMemoryLogs InMemoryLogger {..} = liftIO $ readTVarIO inMemoryVar + +-- | Default stderr logger +stderrLogger :: LogLevel -> Logger +stderrLogger minLvl = + Logger + { minLevel = minLvl + , writeLog = \event -> do + let line = LBSC.unpack (encode event) + hPutStrLn stderr line + } + +-- | Log a structured event through a logger +logEvent :: MonadIO m => Logger -> LogLevel -> Text -> Text -> Map Text Text -> m () +logEvent Logger {..} lvl comp msg meta = + when (lvl >= minLevel) $ liftIO $ do + now <- getCurrentTime + let event = LogEvent lvl now comp msg meta + writeLog event + +-- | Log a debug message +logDebug :: MonadIO m => Logger -> Text -> Text -> m () +logDebug logger comp msg = logEvent logger DebugLevel comp msg Map.empty + +-- | Log an info message +logInfo :: MonadIO m => Logger -> Text -> Text -> m () +logInfo logger comp msg = logEvent logger InfoLevel comp msg Map.empty + +-- | Log a warning message +logWarn :: MonadIO m => Logger -> Text -> Text -> m () +logWarn logger comp msg = logEvent logger WarnLevel comp msg Map.empty + +-- | Log an error message +logError :: MonadIO m => Logger -> Text -> Text -> m () +logError logger comp msg = logEvent logger ErrorLevel comp msg Map.empty + +-------------------------------------------------------------------------------- +-- OpenTelemetry Tracing +-------------------------------------------------------------------------------- + +-- | OpenTelemetry Span Kind +data SpanKind + = InternalSpan + | ClientSpan + | ServerSpan + | ProducerSpan + | ConsumerSpan + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | OpenTelemetry Span Status +data SpanStatus + = StatusUnset + | StatusOk + | StatusError !Text + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | Single OpenTelemetry Span +data Span = Span + { spanName :: !Text + , spanTraceId :: !Text + , spanId :: !Text + , spanParentId :: !(Maybe Text) + , spanKind :: !SpanKind + , spanStartTime :: !UTCTime + , spanEndTime :: !(Maybe UTCTime) + , spanDurationMicros :: !(Maybe Int) + , spanAttributes :: !(Map Text Text) + , spanStatus :: !SpanStatus + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | Thread-safe in-memory OpenTelemetry tracer backed by STM TVar +data OTelTracer = OTelTracer + { tracerTraceId :: !Text + , tracerSpansVar :: !(TVar [Span]) + } + +-- | Construct a new OTelTracer with a given or auto-generated trace ID +newOTelTracer :: MonadIO m => Maybe Text -> m OTelTracer +newOTelTracer mbTraceId = liftIO $ do + tId <- case mbTraceId of + Just tid -> pure tid + Nothing -> do + randVal <- randomRIO (1000000000000000 :: Integer, 9999999999999999 :: Integer) + pure $ "trace-" <> T.pack (show randVal) + var <- newTVarIO [] + pure $ OTelTracer tId var + +-- | Retrieve all recorded spans +getSpans :: MonadIO m => OTelTracer -> m [Span] +getSpans OTelTracer {..} = liftIO $ readTVarIO tracerSpansVar + +-- | Start a new OpenTelemetry span +startSpan :: + MonadIO m => + OTelTracer -> + Text -> + Maybe Text -> + SpanKind -> + Map Text Text -> + m Span +startSpan OTelTracer {..} name parentId kind attrs = liftIO $ do + now <- getCurrentTime + randSpan <- randomRIO (10000000 :: Integer, 99999999 :: Integer) + let sId = "span-" <> T.pack (show randSpan) + sp = + Span + { spanName = name + , spanTraceId = tracerTraceId + , spanId = sId + , spanParentId = parentId + , spanKind = kind + , spanStartTime = now + , spanEndTime = Nothing + , spanDurationMicros = Nothing + , spanAttributes = attrs + , spanStatus = StatusUnset + } + atomically $ modifyTVar' tracerSpansVar (\spans -> spans ++ [sp]) + pure sp + +-- | Complete an active span with final status +endSpan :: MonadIO m => OTelTracer -> Text -> SpanStatus -> m () +endSpan OTelTracer {..} targetSpanId status = liftIO $ do + now <- getCurrentTime + atomically $ modifyTVar' tracerSpansVar (map (finalizeSpan now)) + where + finalizeSpan now sp + | spanId sp == targetSpanId = + let durMicros = round (diffUTCTime now (spanStartTime sp) * 1000000) + in sp + { spanEndTime = Just now + , spanDurationMicros = Just durMicros + , spanStatus = status + } + | otherwise = sp + +-- | Add or update an attribute on an active or completed span +addSpanAttribute :: MonadIO m => OTelTracer -> Text -> Text -> Text -> m () +addSpanAttribute OTelTracer {..} targetSpanId key val = liftIO $ do + atomically $ modifyTVar' tracerSpansVar (map updateAttr) + where + updateAttr sp + | spanId sp == targetSpanId = + sp {spanAttributes = Map.insert key val (spanAttributes sp)} + | otherwise = sp + +-- | Wrap a monadic computation within an OpenTelemetry span +withSpan :: + (MonadIO m, MonadError LangchainError m) => + OTelTracer -> + Text -> + Maybe Text -> + SpanKind -> + Map Text Text -> + m a -> + m a +withSpan tracer name parentId kind attrs action = do + sp <- startSpan tracer name parentId kind attrs + res <- + action `catchError` \err -> do + endSpan tracer (spanId sp) (StatusError (T.pack (show err))) + throwError err + endSpan tracer (spanId sp) StatusOk + pure res + +-- | Export all recorded spans as JSON ByteString +exportSpansJson :: MonadIO m => OTelTracer -> m Text +exportSpansJson tracer = do + spans <- getSpans tracer + pure $ T.pack $ LBSC.unpack $ encode spans diff --git a/src/Langchain/OutputParser/Core.hs b/src/Langchain/OutputParser/Core.hs --- a/src/Langchain/OutputParser/Core.hs +++ b/src/Langchain/OutputParser/Core.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {- | Module: Langchain.OutputParser.Core -Copyright: (c) 2025 Tushar Adhatrao +Copyright: (c) 2026 Tushar Adhatrao License: MIT Maintainer: Tushar Adhatrao Stability: experimental @@ -35,7 +36,7 @@ import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Data.Text.Internal.Search (indices) -import Langchain.Error (LangchainResult, parsingError) +import Langchain.Core.Error (LangchainResult, parsingError) {- | Typeclass for parsing output from language models into specific types. Instances of this class define how to convert a 'Text' output into a value of type 'a'. @@ -131,7 +132,7 @@ newtype FromJSON a => JSONOutputStructure a = JSONOutputStructure { jsonValue :: a } - deriving (Show, Eq, FromJSON) + deriving newtype (Show, Eq, FromJSON) -- | Instance for parsing JSON into any type that implements FromJSON. instance FromJSON a => OutputParser (JSONOutputStructure a) where diff --git a/src/Langchain/OutputParser/Structured.hs b/src/Langchain/OutputParser/Structured.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/OutputParser/Structured.hs @@ -0,0 +1,348 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +{- | +Module : Langchain.OutputParser.Structured +Description : Type-safe structured output extraction using GHC Generics and JSON Schemas +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Generates JSON Schemas automatically from Haskell types using GHC Generics, +prompts the ChatModel for structured JSON output, and parses the response into typed values +with an automatic error-correction retry loop. +-} +module Langchain.OutputParser.Structured + ( StructuredOutput (..) + , TypeSchema (..) + , GRecordSchema (..) + , genericJsonSchema + , toOllamaSchema + , fromOllamaSchema + , structuredInvoke + , structuredInvokeWithRetries + , extractJsonFromMarkdown + ) where + +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.IO.Class (MonadIO) +import Data.Aeson (FromJSON, Value (..), decode, encode, object, (.=)) +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KM +import qualified Data.ByteString.Lazy.Char8 as LBSC +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) +import qualified Data.Map.Strict as Map +import Data.Proxy (Proxy (..)) +import Data.Scientific (Scientific) +import Data.Text (Text) +import qualified Data.Text as TS +import qualified Data.Text.Encoding as TE +import Data.Time (Day, UTCTime) +import qualified Data.Vector as V +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Generics + +import Langchain.Core.Error (LangchainError, parsingError) +import Langchain.Core.Model + ( ChatModel (..) + , Message (..) + , extractMessageText + , systemMessage + , userMessage + ) +import qualified Ollama.Types.Format.SchemaBuilder as SB + +-- | Typeclass for types that declare a JSON Schema and structured parser +class (FromJSON a) => StructuredOutput a where + outputSchema :: Proxy a -> Value + default outputSchema :: (GRecordSchema (Rep a)) => Proxy a -> Value + outputSchema _ = genericJsonSchema (Proxy :: Proxy a) + +-- | Generic JSON Schema derivation helper +genericJsonSchema :: forall a. (GRecordSchema (Rep a)) => Proxy a -> Value +genericJsonSchema _ = + let (props, reqs) = gRecordSchema (Proxy :: Proxy (Rep a)) + in object + [ "type" .= ("object" :: Text) + , "properties" .= object props + , "required" .= reqs + ] + +class GRecordSchema (f :: Type -> Type) where + gRecordSchema :: Proxy f -> ([(Key.Key, Value)], [Text]) + +instance (GRecordSchema f, GRecordSchema g) => GRecordSchema (f :*: g) where + gRecordSchema _ = + let (p1, r1) = gRecordSchema (Proxy :: Proxy f) + (p2, r2) = gRecordSchema (Proxy :: Proxy g) + in (p1 ++ p2, r1 ++ r2) + +instance (GRecordSchema f) => GRecordSchema (M1 D c f) where + gRecordSchema _ = gRecordSchema (Proxy :: Proxy f) + +instance (GRecordSchema f) => GRecordSchema (M1 C c f) where + gRecordSchema _ = gRecordSchema (Proxy :: Proxy f) + +instance (Selector s, TypeSchema a) => GRecordSchema (M1 S s (K1 R a)) where + gRecordSchema _ = + let selNameStr = selName (undefined :: M1 S s (K1 R a) p) + propKey = Key.fromString selNameStr + propSchema = typeJsonSchema (Proxy :: Proxy a) + req = [TS.pack selNameStr | not (isOptionalType (Proxy :: Proxy a))] + in ([(propKey, propSchema)], req) + +-- | Typeclass defining JSON Schema mapping for Haskell primitive and composite types +class TypeSchema a where + typeJsonSchema :: Proxy a -> Value + default typeJsonSchema :: (GRecordSchema (Rep a)) => Proxy a -> Value + typeJsonSchema _ = genericJsonSchema (Proxy :: Proxy a) + + isOptionalType :: Proxy a -> Bool + isOptionalType _ = False + +instance (TypeSchema a) => TypeSchema (Maybe a) where + typeJsonSchema _ = typeJsonSchema (Proxy :: Proxy a) + isOptionalType _ = True + +instance TypeSchema Text where + typeJsonSchema _ = object ["type" .= ("string" :: Text)] + +instance TypeSchema String where + typeJsonSchema _ = object ["type" .= ("string" :: Text)] + +instance TypeSchema Char where + typeJsonSchema _ = object ["type" .= ("string" :: Text)] + +instance TypeSchema Int where + typeJsonSchema _ = object ["type" .= ("integer" :: Text)] + +instance TypeSchema Int8 where + typeJsonSchema _ = object ["type" .= ("integer" :: Text)] + +instance TypeSchema Int16 where + typeJsonSchema _ = object ["type" .= ("integer" :: Text)] + +instance TypeSchema Int32 where + typeJsonSchema _ = object ["type" .= ("integer" :: Text)] + +instance TypeSchema Int64 where + typeJsonSchema _ = object ["type" .= ("integer" :: Text)] + +instance TypeSchema Integer where + typeJsonSchema _ = object ["type" .= ("integer" :: Text)] + +instance TypeSchema Word where + typeJsonSchema _ = object ["type" .= ("integer" :: Text)] + +instance TypeSchema Word8 where + typeJsonSchema _ = object ["type" .= ("integer" :: Text)] + +instance TypeSchema Word16 where + typeJsonSchema _ = object ["type" .= ("integer" :: Text)] + +instance TypeSchema Word32 where + typeJsonSchema _ = object ["type" .= ("integer" :: Text)] + +instance TypeSchema Word64 where + typeJsonSchema _ = object ["type" .= ("integer" :: Text)] + +instance TypeSchema Double where + typeJsonSchema _ = object ["type" .= ("number" :: Text)] + +instance TypeSchema Float where + typeJsonSchema _ = object ["type" .= ("number" :: Text)] + +instance TypeSchema Scientific where + typeJsonSchema _ = object ["type" .= ("number" :: Text)] + +instance TypeSchema Bool where + typeJsonSchema _ = object ["type" .= ("boolean" :: Text)] + +instance TypeSchema UTCTime where + typeJsonSchema _ = + object + [ "type" .= ("string" :: Text) + , "format" .= ("date-time" :: Text) + ] + +instance TypeSchema Day where + typeJsonSchema _ = + object + [ "type" .= ("string" :: Text) + , "format" .= ("date" :: Text) + ] + +instance TypeSchema Value where + typeJsonSchema _ = object ["type" .= ("object" :: Text)] + +instance (TypeSchema a) => TypeSchema (Map.Map Text a) where + typeJsonSchema _ = + object + [ "type" .= ("object" :: Text) + , "additionalProperties" .= typeJsonSchema (Proxy :: Proxy a) + ] + +instance {-# OVERLAPPABLE #-} (TypeSchema a) => TypeSchema [a] where + typeJsonSchema _ = + object + [ "type" .= ("array" :: Text) + , "items" .= typeJsonSchema (Proxy :: Proxy a) + ] + +-- | Convert a Langchain JSON Schema Value into an ollama-haskell Schema +toOllamaSchema :: Value -> Maybe SB.Schema +toOllamaSchema (Object obj) = do + propsVal <- KM.lookup "properties" obj + propsMap <- case propsVal of + Object pObj -> + Just $ + Map.fromList + [ (Key.toText k, SB.Property jt) + | (k, v) <- KM.toList pObj + , Just jt <- [valueToJsonType v] + ] + _ -> Nothing + let reqs = case KM.lookup "required" obj of + Just (Array arr) -> [t | String t <- V.toList arr] + _ -> [] + pure $ SB.Schema propsMap reqs + where + valueToJsonType :: Value -> Maybe SB.JsonType + valueToJsonType (Object vObj) = case KM.lookup "type" vObj of + Just (String "string") -> Just SB.JString + Just (String "integer") -> Just SB.JInteger + Just (String "number") -> Just SB.JNumber + Just (String "boolean") -> Just SB.JBoolean + Just (String "null") -> Just SB.JNull + Just (String "array") -> do + itemVal <- KM.lookup "items" vObj + itemType <- valueToJsonType itemVal + pure $ SB.JArray itemType + Just (String "object") -> do + subSchema <- toOllamaSchema (Object vObj) + pure $ SB.JObject subSchema + _ -> Nothing + valueToJsonType _ = Nothing +toOllamaSchema _ = Nothing + +-- | Convert an ollama-haskell Schema into a Langchain JSON Schema Value +fromOllamaSchema :: SB.Schema -> Value +fromOllamaSchema (SB.Schema props reqs) = + object + [ "type" .= ("object" :: Text) + , "properties" + .= object [Key.fromText k .= jsonTypeToValue jt | (k, SB.Property jt) <- Map.toList props] + , "required" .= reqs + ] + where + jsonTypeToValue :: SB.JsonType -> Value + jsonTypeToValue SB.JString = object ["type" .= ("string" :: Text)] + jsonTypeToValue SB.JInteger = object ["type" .= ("integer" :: Text)] + jsonTypeToValue SB.JNumber = object ["type" .= ("number" :: Text)] + jsonTypeToValue SB.JBoolean = object ["type" .= ("boolean" :: Text)] + jsonTypeToValue SB.JNull = object ["type" .= ("null" :: Text)] + jsonTypeToValue (SB.JArray jt) = + object + [ "type" .= ("array" :: Text) + , "items" .= jsonTypeToValue jt + ] + jsonTypeToValue (SB.JObject subSchema) = fromOllamaSchema subSchema + +{- | Invoke a 'ChatModel' and extract a typed 'StructuredOutput' value. + +This function injects the JSON Schema into a system prompt and parses the LLM's response, +retrying up to 3 times with error feedback if parsing fails. + +__Provider-Specific Grammar Enforcement:__ +Note that 'structuredInvoke' relies on prompt-based instructions and schema validation across +generic 'ChatModel' instances. If you are using Ollama and want strict token-level schema +enforcement (where Ollama guarantees valid JSON conforming to the schema at generation time), +use 'withStructuredOutput' or set 'chatFormat' on 'ChatRequest' directly: + +@ +import Langchain.Provider.Ollama (ChatRequest(..), SchemaFormat(..)) +let req = def { chatFormat = Just (SchemaFormat (toOllamaSchema (outputSchema (Proxy :: Proxy MyType)))) } +@ +-} +structuredInvoke :: + forall a model m. + (StructuredOutput a, ChatModel model, MonadIO m, MonadError LangchainError m) => + model -> + [Message] -> + m a +structuredInvoke model msgs = structuredInvokeWithRetries model msgs 3 + +-- | Invoke a ChatModel with up to N retry iterations with error-correction feedback +structuredInvokeWithRetries :: + forall a model m. + (StructuredOutput a, ChatModel model, MonadIO m, MonadError LangchainError m) => + model -> + [Message] -> + Int -> + m a +structuredInvokeWithRetries model baseMsgs maxAttempts = do + let schema = outputSchema (Proxy :: Proxy a) + schemaStr = TE.decodeUtf8 $ LBSC.toStrict $ encode schema + systemInstruction = + systemMessage + ( "You are a structured data extractor. You must respond ONLY with a valid JSON object matching this JSON Schema:\n" + <> schemaStr + <> "\nDo NOT wrap the JSON in Markdown backticks or provide conversational text." + ) + fullConversation = systemInstruction : baseMsgs + go fullConversation maxAttempts + where + go conv attemptsLeft = do + resp <- invoke model conv Nothing + let rawText = extractMessageText resp + cleanJson = extractJsonFromMarkdown rawText + bs = LBSC.fromStrict (TE.encodeUtf8 cleanJson) + case decode bs of + Just parsedVal -> pure parsedVal + Nothing -> + if attemptsLeft <= 1 + then + throwError $ + parsingError + ( "Failed to parse structured JSON output from LLM: " + <> rawText + <> " (Schema: " + <> TE.decodeUtf8 (LBSC.toStrict (encode (outputSchema (Proxy :: Proxy a)))) + <> ")" + ) + (Just "structuredInvoke") + Nothing + else do + let correctionMsg = + userMessage + ( "Your previous response was not valid JSON matching the schema. Error: failed to parse.\n" + <> "Please re-output ONLY valid JSON matching the schema." + ) + updatedConv = conv ++ [resp, correctionMsg] + go updatedConv (attemptsLeft - 1) + +-- | Robust helper to unwrap JSON from markdown ```json ``` blocks +extractJsonFromMarkdown :: Text -> Text +extractJsonFromMarkdown t = + let stripped = TS.strip t + in if "```json" `TS.isPrefixOf` stripped + then + let afterPrefix = TS.drop 7 stripped + in case TS.breakOn "```" afterPrefix of + (jsonPart, _) -> TS.strip jsonPart + else + if "```" `TS.isPrefixOf` stripped + then + let afterPrefix = TS.drop 3 stripped + in case TS.breakOn "```" afterPrefix of + (jsonPart, _) -> TS.strip jsonPart + else stripped diff --git a/src/Langchain/Prelude.hs b/src/Langchain/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Prelude.hs @@ -0,0 +1,439 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} + +{- | +Module : Langchain.Prelude +Description : Canonical umbrella re-export module for langchain-hs +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Exports all core data types, typeclasses, models, vector stores, memory stores, +graph orchestration primitives, advanced multi-agent patterns, guardrails, MCP client, +observability, structured logging, circuit breakers, pipeline DSLs, and runtime execution monads. +-} +module Langchain.Prelude + ( -- * Core Monad & Errors + LangchainT + , runLangchainT + , throwLangchainError + , LangchainError (..) + , ErrorContext (..) + , errorMessage + , mkContext + , mkContextIO + , LangchainResult + , llmError + , parsingError + , vectorStoreError + , documentLoaderError + , embeddingError + , runnableError + , toolError + , agentError + , memoryError + , networkError + , configurationError + , validationError + , internalError + + -- * Multi-Modal Models & Messages + , ChatModel (..) + , Message (..) + , Role + , ContentBlock (..) + , ToolCall (..) + , textMessage + , userMessage + , systemMessage + , assistantMessage + , toolMessage + , imageMessage + , extractMessageText + , StreamEvent + ( LLMStart + , LLMChunk + , LLMEnd + , ToolStart + , ToolEnd + , ToolErrorEvent + , ChainStart + , ChainEnd + , NodeStart + , NodeEnd + ) + , TokenUsage (..) + , EventStream + , collectEvents + , printEvents + + -- * Pure AST Pipelines (RunnableTree) + , RunnableTree (..) + , (|>>) + , (&>&) + , interpret + , runLambda + , runPrim + , runPure + , runPassthrough + , runIdent + , runBranch + , runFallback + , runChat + , runModel + , runRetriever + , ModelRunnable (..) + , TextModelRunnable (..) + + -- * Effect-Polymorphic Tools + , Tool (..) + , createTool + , toolToValue + , ToolBinder (..) + , DeriveToolSchema (..) + , deriveToolParametersSchema + , executeToolAsync + , executeToolWithTimeout + , executeToolBatchConcurrently + + -- * State Graphs & Multi-Agent + , StateGraph (..) + , Node (Node) + , Edge (..) + , NodeId + , startNodeId + , endNodeId + , StateReducer + , emptyStateGraph + , addNode + , addEdge + , addConditionalEdge + , compileGraph + , runGraph + , appendMessagesReducer + , replaceFieldReducer + , Checkpointer (..) + , MemoryCheckpointer (..) + , newMemoryCheckpointer + , SQLiteCheckpointer (..) + , newSQLiteCheckpointer + , hitlNode + , resumeGraph + , supervisorNode + , embedSubGraphNode + , parallelNode + , addParallelNodes + + -- * Advanced Agent Patterns + , PlanStep (..) + , Plan (..) + , StepExecutor (..) + , PlanAndExecuteAgent (..) + , newPlanAndExecuteAgent + , newPlanAndExecuteAgentWithTools + , runPlanAndExecute + + -- * Guardrails & Safety + , GuardrailResult (..) + , Guardrail (..) + , contentSafetyGuardrail + , topicGuardrail + , outputLengthGuardrail + , composeGuardrails + , withGuardrails + + -- * Model Context Protocol (MCP) Client + , McpTransport (..) + , McpToolInfo (..) + , McpResource (..) + , McpClient (..) + , newStdioMcpClient + , newHttpMcpClient + , listMcpTools + , callMcpTool + , mcpToolToLangchainTool + + -- * Telemetry, Logging & OpenTelemetry + , LogLevel (..) + , LogEvent (..) + , Logger (..) + , InMemoryLogger (..) + , newInMemoryLogger + , getInMemoryLogs + , stderrLogger + , logEvent + , logDebug + , logInfo + , logWarn + , logError + , SpanKind (..) + , SpanStatus (..) + , Span (..) + , OTelTracer (..) + , newOTelTracer + , getSpans + , startSpan + , endSpan + , addSpanAttribute + , withSpan + , exportSpansJson + + -- * Callbacks + , CallbackEvent (..) + , CallbackHandler (..) + , CallbackManager (..) + , newCallbackManager + , registerHandler + , dispatchEvent + , dispatchEventAsync + , newLoggingCallbackHandler + , getCallbackLogs + + -- * Resilience + , CircuitState (..) + , CircuitBreakerConfig (..) + , defaultCircuitConfig + , CircuitBreaker (..) + , newCircuitBreaker + , getCircuitState + , withCircuitBreaker + + -- * Memory Systems + , BaseMemory (..) + , WindowBufferMemory (..) + , newWindowBufferMemory + , TokenBufferMemory (..) + , newTokenBufferMemory + , countTokens + , SummaryMemory (..) + , newSummaryMemory + , EntityMemory (..) + , newEntityMemory + , initialMessages + , trimMessages + + -- * Vector Stores & Retrieval + , VectorStore (..) + , InMemory (..) + , emptyInMemoryVectorStore + , fromDocuments + , SqliteVecStore (..) + , newSqliteVecStore + , Retriever (..) + , VectorStoreRetriever (..) + , retrieveWithCallbacks + + -- * Embeddings + , Embeddings (..) + , OllamaEmbeddings (..) + , OpenAIEmbeddings (OpenAIEmbeddings) + , defaultOpenAIEmbeddings + , textEmbedding3Small + , textEmbedding3Large + , textEmbeddingAda + + -- * Document Loaders + , Document (..) + , BaseLoader (..) + , FileLoader (..) + , DirectoryLoader (..) + , DirectoryLoaderOptions (..) + , defaultDirectoryLoaderOptions + , CsvLoader (..) + , defaultCsvLoader + + -- * Prompt Templates + , PromptTemplate (..) + , PromptTemplateOptions (..) + , TemplateFormat (..) + , defaultPromptTemplateOptions + , fromTemplate + , fromTemplateWithOptions + , fromTemplateWithFormat + , partialPromptTemplate + , FewShotPromptTemplate (..) + , renderPrompt + , renderFewShotPrompt + + -- * Text Splitters + , CharacterSplitterOps (CharacterSplitterOps) + , defaultCharacterSplitterOps + , splitText + , RecursiveCharacterSplitterOps (RecursiveCharacterSplitterOps) + , defaultRecursiveCharacterSplitterOps + , splitTextRecursive + , MarkdownSplitterOps (MarkdownSplitterOps) + , defaultMarkdownSplitterOps + , splitMarkdown + , splitMarkdownToChunks + , TokenSplitterOps (TokenSplitterOps) + , defaultTokenSplitterOps + , splitByTokens + , Language (..) + , CodeSplitterOps (CodeSplitterOps) + , splitCode + + -- * Caching & Resilience + , CacheBackend (..) + , InMemoryCache (..) + , newInMemoryCache + , SQLiteCache (..) + , newSQLiteCache + , CachedModel (..) + , withCaching + , RetryPolicy (RetryPolicy) + , defaultRetryPolicy + , withRetry + , RateLimiter (..) + , newRateLimiter + , withRateLimit + + -- * Chains + , RetrievalQA (RetrievalQA) + , newRetrievalQA + , runRetrievalQA + , MapReduceChain (..) + , newMapReduceChain + , runMapReduceChain + + -- * Structured Output & Parsers + , OutputParser (..) + , CommaSeparatedList (..) + , JSONOutputStructure (..) + , NumberSeparatedList (..) + , StructuredOutput (..) + , TypeSchema (..) + , toOllamaSchema + , fromOllamaSchema + , structuredInvoke + , structuredInvokeWithRetries + , withJsonFormat + , withSchemaFormat + , withStructuredOutput + + -- * Agents & Execution + , ReActAgent (ReActAgent) + , AgentStep (..) + , createReActAgent + , reactStep + , runReActAgent + + -- * Standard Tools + , shellTool + + -- * Hybrid Retrieval & BM25 + , BM25Index (..) + , newBM25Index + , newBM25IndexWithParams + , addDocumentsBM25 + , bm25Search + , bm25SearchWithScores + , HybridRetriever (..) + , newHybridRetriever + , newHybridRetrieverWithWeights + , searchHybrid + , searchHybridWithScores + , reciprocalRankFusion + + -- * Providers + , Ollama (..) + , OllamaClientConfig (..) + , defaultConfig + , newOllama + , newOllamaWithClient + , ModelOptions (..) + , defaultOptions + , withOptions + , chatRequestFor + , resolveChatRequest + , withTools + , toOllamaTool + , toOllamaTools + , OllamaWithTools (..) + , bindTools + , OpenAI + , newOpenAI + , Gemini + , newGemini + ) where + +import Langchain.Agent.PlanAndExecute +import Langchain.Agent.ReAct +import Langchain.Cache.Core +import Langchain.Callback.Manager +import Langchain.Chain.MapReduce +import Langchain.Chain.RetrievalQA +import Langchain.Core.Error +import Langchain.Core.Model +import Langchain.Core.Monad +import Langchain.Core.Runnable hiding (invoke) +import Langchain.Core.Stream +import Langchain.Core.Tool +import Langchain.DocumentLoader.Core +import Langchain.DocumentLoader.Csv +import Langchain.DocumentLoader.DirectoryLoader +import Langchain.DocumentLoader.FileLoader +import Langchain.Embeddings.Core +import Langchain.Embeddings.Ollama (OllamaEmbeddings (..)) +import Langchain.Embeddings.OpenAI + ( OpenAIEmbeddings (OpenAIEmbeddings) + , defaultOpenAIEmbeddings + , textEmbedding3Large + , textEmbedding3Small + , textEmbeddingAda + ) +import Langchain.Graph.Checkpointer +import Langchain.Graph.HITL +import Langchain.Graph.MultiAgent +import Langchain.Graph.Parallel +import Langchain.Graph.StateGraph +import Langchain.Guardrail.Core +import Langchain.MCP.Client +import Langchain.Memory.Core +import Langchain.Memory.Entity +import Langchain.Memory.Summary +import Langchain.Observability +import Langchain.OutputParser.Core +import Langchain.OutputParser.Structured +import Langchain.PromptTemplate.FewShot +import Langchain.PromptTemplate.Prompt +import Langchain.Provider.Gemini (Gemini, newGemini) +import Langchain.Provider.Ollama + ( ModelOptions (..) + , Ollama (..) + , OllamaClientConfig (..) + , OllamaWithTools (..) + , bindTools + , chatRequestFor + , defaultConfig + , defaultOptions + , newOllama + , newOllamaWithClient + , resolveChatRequest + , toOllamaTool + , toOllamaTools + , withJsonFormat + , withOptions + , withSchemaFormat + , withStructuredOutput + , withTools + ) +import Langchain.Provider.OpenAI (OpenAI, newOpenAI) +import Langchain.Resilience.CircuitBreaker +import Langchain.Resilience.Retry +import Langchain.Retriever.BM25 +import Langchain.Retriever.Core +import Langchain.Retriever.Hybrid +import Langchain.TextSplitter.Character +import Langchain.TextSplitter.Code +import Langchain.TextSplitter.Markdown +import Langchain.TextSplitter.RecursiveCharacter +import Langchain.TextSplitter.Token +import Langchain.Tool.Async +import Langchain.Tool.Binding +import Langchain.Tool.GenericSchema +import Langchain.Tool.Shell (shellTool) +import Langchain.VectorStore.Core +import Langchain.VectorStore.InMemory +import Langchain.VectorStore.SqliteVec diff --git a/src/Langchain/PromptTemplate.hs b/src/Langchain/PromptTemplate.hs deleted file mode 100644 --- a/src/Langchain/PromptTemplate.hs +++ /dev/null @@ -1,167 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} - -{- | -Module: Langchain.PromptTemplate -Copyright: (c) 2025 Tushar Adhatrao -License: MIT -Maintainer: Tushar Adhatrao -Stability: experimental - -This module provides types and functions for working with prompt templates in Langchain. -Prompt templates are used to structure inputs for language models, allowing for dynamic -insertion of variables into predefined text formats. They are essential for creating -flexible and reusable prompts that can be customized based on input data. - -The main types are: - -* 'PromptTemplate': A simple template with placeholders for variables. -* 'FewShotPromptTemplate': A template that includes few-shot examples for better context, - useful in scenarios like few-shot learning. - -These types are designed to be compatible with the Langchain Python library's prompt template -functionality: [Langchain PromptTemplate](https://python.langchain.com/docs/concepts/prompt_templates/). - -== Examples - -See the documentation for 'renderPrompt' and 'renderFewShotPrompt' for usage examples. --} -module Langchain.PromptTemplate - ( -- * Core Types - PromptTemplate (..) - , FewShotPromptTemplate (..) - - -- * Rendering Functions - , renderPrompt - , renderFewShotPrompt - ) where - -import qualified Data.Map.Strict as HM -import Data.Text (Text) -import qualified Data.Text as T -import Langchain.Error (LangchainResult, validationError) -import Langchain.Runnable.Core (Runnable (..)) - --- TODO: Add Mechanism for custom example selector - -{- | Represents a prompt template with a template string. -The template string can contain placeholders of the form {key}, -where key is a sequence of alphanumeric characters and underscores. --} -newtype PromptTemplate = PromptTemplate - { templateString :: Text - } - deriving (Show, Eq) - -{- | Render a prompt template with the given variables. -Returns either an error message if a variable is missing or the rendered template. - -=== Using 'renderPrompt' - -To render a prompt template with variables: - -@ -let template = PromptTemplate "Hello, {name}! Welcome to {place}." -vars = HM.fromList [("name", "Alice"), ("place", "Wonderland")] -result <- renderPrompt template vars --- Result: Right "Hello, Alice! Welcome to Wonderland." -@ - -If a variable is missing: - -@ -let vars = HM.fromList [("name", "Alice")] -result <- renderPrompt template vars --- Result: Left "Missing variable: place" -@ --} -renderPrompt :: PromptTemplate -> HM.Map Text Text -> LangchainResult Text -renderPrompt (PromptTemplate template) vars = interpolate vars template - -{- | Represents a few-shot prompt template with examples. -This type allows for creating prompts that include example inputs and outputs, -which can be useful for few-shot learning scenarios. --} -data FewShotPromptTemplate = FewShotPromptTemplate - { fsPrefix :: Text - -- ^ Text before the examples - , fsExamples :: [HM.Map Text Text] - -- ^ List of example variable maps - , fsExampleTemplate :: Text - -- ^ Template for formatting each example - , fsExampleSeparator :: Text - -- ^ Separator between formatted examples - , fsSuffix :: Text - -- ^ Text after the examples, with placeholders - } - deriving (Show, Eq) - -{- | Render a few-shot prompt template with the given input variables. -Returns either an error message if interpolation fails or the fully rendered prompt. - -=== Using 'renderFewShotPrompt' - -To render a few-shot prompt template: - -@ -let fewShotTemplate = FewShotPromptTemplate - { fsPrefix = "Examples of {type}:\n" - , fsExamples = - [ HM.fromList [("input", "Hello"), ("output", "Bonjour")] - , HM.fromList [("input", "Goodbye"), ("output", "Au revoir")] - ] - , fsExampleTemplate = "Input: {input}\nOutput: {output}\n" - , fsExampleSeparator = "\n" - , fsSuffix = "Now translate: {query}" - } -result <- renderFewShotPrompt fewShotTemplate --- Result: Right "Examples of {type}:\nInput: Hello\nOutput: Bonjour\n\nInput: Goodbye\nOutput: Au revoir\nNow translate: {query}" -@ --} -renderFewShotPrompt :: FewShotPromptTemplate -> LangchainResult Text -renderFewShotPrompt FewShotPromptTemplate {..} = do - -- Format each example using the example template - formattedExamples <- - mapM - (`interpolate` fsExampleTemplate) - fsExamples - -- Join the formatted examples with the separator - let examplesText = T.intercalate fsExampleSeparator formattedExamples - -- Combine prefix, examples, and suffix - return $ fsPrefix <> examplesText <> fsSuffix - -{- | Interpolate variables into a template string. -Placeholders are of the form {key}, where key is a sequence of alphanumeric characters and underscores. --} -interpolate :: HM.Map Text Text -> Text -> LangchainResult Text -interpolate vars = go - where - go :: Text -> LangchainResult Text - go t = - case T.breakOn "{" t of - (before, after) | T.null after -> Right before - (before, after') -> - case T.breakOn "}" (T.drop 1 after') of - (_, after'') | T.null after'' -> Left $ validationError "Unclosed brace" Nothing Nothing - (key, after''') -> - let key' = T.strip key - in case HM.lookup key' vars of - Just val -> do - rest <- go (T.drop 1 after''') - return $ before <> val <> rest - Nothing -> Left $ validationError ("Missing variable: " <> key') (Just key') Nothing - -instance Runnable PromptTemplate where - type RunnableInput PromptTemplate = HM.Map Text Text - type RunnableOutput PromptTemplate = Text - - invoke template variables = pure $ renderPrompt template variables - -{- -instance Runnable FewShotPromptTemplate where - type RunnableInput FewShotPromptTemplate = Maybe [Text] - type RunnableOutput FewShotPromptTemplate = Text - - invoke t m = pure $ renderFewShotPrompt t m --} diff --git a/src/Langchain/PromptTemplate/Chat.hs b/src/Langchain/PromptTemplate/Chat.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/PromptTemplate/Chat.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{- | +Module : Langchain.PromptTemplate.Chat +Description : Chat prompt template primitives +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Minimal chat prompt primitives ported from LangChain Python chat prompts. +-} +module Langchain.PromptTemplate.Chat + ( BaseMessagePromptTemplate (..) + , extractTemplateVariables + ) where + +import Langchain.Core.Error (LangchainError) +import Langchain.Core.Model.Types (Message) +import Langchain.PromptTemplate.Prompt (extractTemplateVariables) + +-- | Base class for message prompt templates. +class BaseMessagePromptTemplate template input where + formatMessages :: template -> input -> Either LangchainError [Message] diff --git a/src/Langchain/PromptTemplate/Chat/ChatPromptTemplate.hs b/src/Langchain/PromptTemplate/Chat/ChatPromptTemplate.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/PromptTemplate/Chat/ChatPromptTemplate.hs @@ -0,0 +1,451 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Langchain.PromptTemplate.Chat.ChatPromptTemplate +Description : ChatPromptTemplate prompt template +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +-} +module Langchain.PromptTemplate.Chat.ChatPromptTemplate + ( ChatPromptTemplate (..) + , ChatPromptMessage + , ContentPromptBlock (..) + , ChatPromptInput (..) + , ChatPromptValue (..) + , PartialValue (..) + , fromTemplate + , fromTemplateWithOptions + , fromMessages + , message + , templateMessage + , templateMessageWithFormat + , contentMessage + , messagesPlaceholder + , messagesPlaceholderWithOptions + , append + , extend + , partial + , invoke + , formatPrompt + , format + , toMessages + , toString + ) where + +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, withObject, (.:), (.:?), (.=)) +import Data.Aeson.Types (Parser) +import Data.Either (fromRight) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.Strict as Map +import Data.Maybe (isJust) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) + +import Langchain.Core.Error (LangchainError, validationError) +import Langchain.Core.Model.Types + ( ContentBlock (..) + , ImageContent (..) + , ImageSource (..) + , Message (..) + , Role (..) + , formatMessageString + , textMessage + , userMessage + ) +import Langchain.PromptTemplate.Chat (BaseMessagePromptTemplate (formatMessages)) +import Langchain.PromptTemplate.Chat.MessagesPlaceholder + ( MessagesPlaceholder (..) + , messagesPlaceholderVariableName + ) +import qualified Langchain.PromptTemplate.Chat.MessagesPlaceholder as MessagesPlaceholder +import Langchain.PromptTemplate.Prompt (PromptTemplateOptions, TemplateFormat (..)) +import qualified Langchain.PromptTemplate.Prompt as Prompt + +-- | A single chat message template inside a chat prompt. +data ChatPromptMessage + = HumanMessagePrompt Prompt.PromptTemplate + | SystemMessagePrompt Prompt.PromptTemplate + | AIMessagePrompt Prompt.PromptTemplate + | ChatMessagePrompt Role Prompt.PromptTemplate + | ContentMessagePrompt Role [ContentPromptBlock] + | MessagesPlaceholderPrompt MessagesPlaceholder (Maybe [Message]) + | StaticMessage Message + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | A templated block inside a multipart chat message. +data ContentPromptBlock + = TextPromptBlock TemplateFormat Text + | ImagePromptBlock TemplateFormat ImageContent + deriving (Show, Eq, Generic) + +instance ToJSON ContentPromptBlock where + toJSON (TextPromptBlock templateFormat template) = + object + [ "type" .= ("text_prompt" :: Text) + , "templateFormat" .= templateFormat + , "template" .= template + ] + toJSON (ImagePromptBlock templateFormat imageContent) = + object + [ "type" .= ("image_prompt" :: Text) + , "templateFormat" .= templateFormat + , "imageContent" .= imageContentToJSON imageContent + ] + +instance FromJSON ContentPromptBlock where + parseJSON = withObject "ContentPromptBlock" $ \value -> do + blockType <- value .: "type" + case (blockType :: Text) of + "text_prompt" -> TextPromptBlock <$> value .: "templateFormat" <*> value .: "template" + "image_prompt" -> + ImagePromptBlock <$> value .: "templateFormat" <*> (value .: "imageContent" >>= parseImageContent) + other -> fail $ "Unknown ContentPromptBlock type: " ++ show other + +imageContentToJSON :: ImageContent -> Value +imageContentToJSON ImageContent {imageSource = source, imageDetail = detail, imageMetadata = metadata} = + object + [ "source" .= imageSourceToJSON source + , "detail" .= detail + , "metadata" .= metadata + ] + +imageSourceToJSON :: ImageSource -> Value +imageSourceToJSON (ImageBase64 mime sourceData) = + object + [ "type" .= ("base64" :: Text) + , "mimeType" .= mime + , "data" .= sourceData + ] +imageSourceToJSON (ImageUrl url) = + object + [ "type" .= ("url" :: Text) + , "url" .= url + ] + +parseImageContent :: Value -> Parser ImageContent +parseImageContent = withObject "ImageContent" $ \value -> + ImageContent + <$> (value .: "source" >>= parseImageSource) + <*> value .:? "detail" + <*> value .:? "metadata" + +parseImageSource :: Value -> Parser ImageSource +parseImageSource = withObject "ImageSource" $ \value -> do + sourceType <- value .: "type" + case (sourceType :: Text) of + "base64" -> ImageBase64 <$> value .:? "mimeType" <*> value .: "data" + "url" -> ImageUrl <$> value .: "url" + other -> fail $ "Unknown ImageSource type: " ++ show other + +-- | A chat prompt template made of ordered message templates. +data ChatPromptTemplate = ChatPromptTemplate + { messages :: [ChatPromptMessage] + , inputVariables :: [Text] + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | A rendered chat prompt as concrete messages. +newtype ChatPromptValue = ChatPromptValue + { messages :: [Message] + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | Inputs accepted by 'invoke' for chat prompts. +data ChatPromptInput + = ChatPromptVariables (Map.Map Text Text) + | ChatPromptMessageList [Message] + | ChatPromptInputs (Map.Map Text Text) (Map.Map Text [Message]) + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | Partial values that can pre-bind text or message placeholders. +data PartialValue + = PartialText Text + | PartialMessages [Message] + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | Create a single-message user chat prompt from raw text. +fromTemplate :: Text -> ChatPromptTemplate +fromTemplate template = fromTemplateWithOptions template Prompt.defaultPromptTemplateOptions + +-- | Create a single-message user chat prompt with partial variables. +fromTemplateWithOptions :: Text -> PromptTemplateOptions -> ChatPromptTemplate +fromTemplateWithOptions template options = + let promptTemplate = Prompt.fromTemplateWithOptions template options + in ChatPromptTemplate + { messages = [ChatMessagePrompt User promptTemplate] + , inputVariables = Prompt.inputVariables promptTemplate + } + +-- | Create a chat prompt from an explicit list of message templates. +fromMessages :: [ChatPromptMessage] -> ChatPromptTemplate +fromMessages promptMessages = + ChatPromptTemplate + { messages = promptMessages + , inputVariables = unique $ concatMap messageInputVariables promptMessages + } + +-- | Wrap a concrete message as part of a chat prompt. +message :: Message -> ChatPromptMessage +message = StaticMessage + +-- | Create a templated message for a specific role. +templateMessage :: Role -> Text -> ChatPromptMessage +templateMessage role = ChatMessagePrompt role . Prompt.fromTemplate + +-- | Create a templated message for a specific role and template format. +templateMessageWithFormat :: Role -> TemplateFormat -> Text -> ChatPromptMessage +templateMessageWithFormat role templateFormat template = + ChatMessagePrompt role $ + Prompt.fromTemplateWithFormat template templateFormat Map.empty + +-- | Create a multipart content message for a specific role. +contentMessage :: Role -> [ContentPromptBlock] -> ChatPromptMessage +contentMessage = ContentMessagePrompt + +-- | Create a placeholder for an injected message list. +messagesPlaceholder :: Text -> ChatPromptMessage +messagesPlaceholder name = messagesPlaceholderWithOptions $ MessagesPlaceholder.messagesPlaceholderOptions name + +-- | Create a message-list placeholder with explicit options. +messagesPlaceholderWithOptions :: + MessagesPlaceholder.MessagesPlaceholderOptions -> ChatPromptMessage +messagesPlaceholderWithOptions options = + MessagesPlaceholderPrompt (MessagesPlaceholder.messagesPlaceholderWithOptions options) Nothing + +-- | Append one message template to the end of a chat prompt. +append :: ChatPromptTemplate -> ChatPromptMessage -> ChatPromptTemplate +append chatPromptTemplate promptMessage = extend chatPromptTemplate [promptMessage] + +-- | Append multiple message templates to the end of a chat prompt. +extend :: ChatPromptTemplate -> [ChatPromptMessage] -> ChatPromptTemplate +extend ChatPromptTemplate {messages = promptMessages} newMessages = + fromMessages $ promptMessages <> newMessages + +-- | Apply partial text and message bindings to a chat prompt. +partial :: ChatPromptTemplate -> Map.Map Text PartialValue -> ChatPromptTemplate +partial ChatPromptTemplate {messages = promptMessages} partialVariables = + fromMessages $ map (`partialMessage` partialVariables) promptMessages + +-- | Render a chat prompt to concrete messages. +formatPrompt :: ChatPromptTemplate -> Map.Map Text Text -> Either LangchainError ChatPromptValue +formatPrompt ChatPromptTemplate {messages = promptMessages} variables = + formatPromptWithMessages promptMessages variables Map.empty + +-- | Render a chat prompt with either variables or message-list inputs. +invoke :: ChatPromptTemplate -> ChatPromptInput -> Either LangchainError ChatPromptValue +invoke chatPromptTemplate (ChatPromptVariables variables) = formatPrompt chatPromptTemplate variables +invoke ChatPromptTemplate {messages = [MessagesPlaceholderPrompt placeholder _]} (ChatPromptMessageList promptMessages) = + ChatPromptValue + <$> formatMessages + placeholder + (Map.singleton (messagesPlaceholderVariableName placeholder) promptMessages) +invoke ChatPromptTemplate {messages = promptMessages} (ChatPromptInputs variables messageVariables) = + formatPromptWithMessages promptMessages variables messageVariables +invoke _ (ChatPromptMessageList _) = + Left $ + validationError + "List input is only supported for a single MessagesPlaceholder" + (Just "ChatPromptTemplate") + (Just "invoke") + +-- | Render a chat prompt to a single formatted text value. +format :: ChatPromptTemplate -> Map.Map Text Text -> Either LangchainError Text +format chatPromptTemplate variables = toString <$> formatPrompt chatPromptTemplate variables + +-- | Extract the concrete messages from a rendered chat prompt. +toMessages :: ChatPromptValue -> [Message] +toMessages (ChatPromptValue promptMessages) = promptMessages + +-- | Render a chat prompt as newline-separated message text. +toString :: ChatPromptValue -> Text +toString (ChatPromptValue promptMessages) = + T.intercalate "\n" $ map formatMessageString promptMessages + +messageInputVariables :: ChatPromptMessage -> [Text] +messageInputVariables (HumanMessagePrompt promptTemplate) = Prompt.inputVariables promptTemplate +messageInputVariables (SystemMessagePrompt promptTemplate) = Prompt.inputVariables promptTemplate +messageInputVariables (AIMessagePrompt promptTemplate) = Prompt.inputVariables promptTemplate +messageInputVariables (ChatMessagePrompt _ promptTemplate) = Prompt.inputVariables promptTemplate +messageInputVariables (ContentMessagePrompt _ blocks) = unique $ concatMap contentBlockInputVariables blocks +messageInputVariables + ( MessagesPlaceholderPrompt + MessagesPlaceholder + { variableName = variableName' + , optional = optional' + } + storedMessages + ) + | optional' || isJust storedMessages = [] + | otherwise = [variableName'] +messageInputVariables (StaticMessage _) = [] + +partialMessage :: ChatPromptMessage -> Map.Map Text PartialValue -> ChatPromptMessage +partialMessage (HumanMessagePrompt promptTemplate) partialVariables = + HumanMessagePrompt $ + Prompt.partialPromptTemplate promptTemplate (textPartialVariables partialVariables) +partialMessage (SystemMessagePrompt promptTemplate) partialVariables = + SystemMessagePrompt $ + Prompt.partialPromptTemplate promptTemplate (textPartialVariables partialVariables) +partialMessage (AIMessagePrompt promptTemplate) partialVariables = + AIMessagePrompt $ + Prompt.partialPromptTemplate promptTemplate (textPartialVariables partialVariables) +partialMessage (ChatMessagePrompt role promptTemplate) partialVariables = + ChatMessagePrompt role $ + Prompt.partialPromptTemplate promptTemplate (textPartialVariables partialVariables) +partialMessage (ContentMessagePrompt role blocks) partialVariables = + ContentMessagePrompt role $ + map (\block -> partialContentBlock block (textPartialVariables partialVariables)) blocks +partialMessage (MessagesPlaceholderPrompt placeholder storedMessages) partialVariables = + MessagesPlaceholderPrompt placeholder $ + case Map.lookup (messagesPlaceholderVariableName placeholder) partialVariables of + Just (PartialMessages promptMessages) -> Just promptMessages + _ -> storedMessages +partialMessage (StaticMessage staticMessage) _ = StaticMessage staticMessage + +textPartialVariables :: Map.Map Text PartialValue -> Map.Map Text Text +textPartialVariables = Map.mapMaybe toText + where + toText :: PartialValue -> Maybe Text + toText (PartialText value) = Just value + toText (PartialMessages _) = Nothing + +formatPromptWithMessages :: + [ChatPromptMessage] -> + Map.Map Text Text -> + Map.Map Text [Message] -> + Either LangchainError ChatPromptValue +formatPromptWithMessages promptMessages variables messageVariables = + ChatPromptValue . concat + <$> traverse (\promptMessage -> formatMessage promptMessage variables messageVariables) promptMessages + +formatMessage :: + ChatPromptMessage -> Map.Map Text Text -> Map.Map Text [Message] -> Either LangchainError [Message] +formatMessage (HumanMessagePrompt promptTemplate) variables _ = + (: []) . userMessage <$> Prompt.renderPrompt promptTemplate variables +formatMessage (SystemMessagePrompt promptTemplate) variables _ = + (: []) . textMessage System <$> Prompt.renderPrompt promptTemplate variables +formatMessage (AIMessagePrompt promptTemplate) variables _ = + (: []) . textMessage Assistant <$> Prompt.renderPrompt promptTemplate variables +formatMessage (ChatMessagePrompt role promptTemplate) variables _ = + (: []) . textMessage role <$> Prompt.renderPrompt promptTemplate variables +formatMessage (ContentMessagePrompt role blocks) variables _ = do + renderedBlocks <- concat <$> traverse (renderContentBlock variables) blocks + case NonEmpty.nonEmpty renderedBlocks of + Nothing -> Right [] + Just nonEmptyBlocks -> Right [Message role nonEmptyBlocks Nothing Nothing Nothing Map.empty] +formatMessage (MessagesPlaceholderPrompt placeholder storedMessages) _ messageVariables = + formatMessages placeholder $ + case storedMessages of + Nothing -> messageVariables + Just promptMessages -> + messageVariables + `Map.union` Map.singleton (messagesPlaceholderVariableName placeholder) promptMessages +formatMessage (StaticMessage staticMessage) _ _ = Right [staticMessage] + +contentBlockInputVariables :: ContentPromptBlock -> [Text] +contentBlockInputVariables (TextPromptBlock templateFormat template) = + Prompt.extractTemplateVariablesWithFormat templateFormat template +contentBlockInputVariables (ImagePromptBlock templateFormat imageContent) = + imageContentInputVariables templateFormat imageContent + +partialContentBlock :: ContentPromptBlock -> Map.Map Text Text -> ContentPromptBlock +partialContentBlock (TextPromptBlock templateFormat template) partials = + TextPromptBlock templateFormat $ renderPartial templateFormat partials template +partialContentBlock (ImagePromptBlock templateFormat imageContent) partials = + ImagePromptBlock templateFormat $ partialImageContent templateFormat partials imageContent + +renderContentBlock :: + Map.Map Text Text -> ContentPromptBlock -> Either LangchainError [ContentBlock] +renderContentBlock variables (TextPromptBlock templateFormat template) = do + rendered <- renderTemplate templateFormat variables template + pure [TextBlock rendered | not (T.null rendered)] +renderContentBlock variables (ImagePromptBlock templateFormat imageContent) = do + renderedImage <- renderImageContent templateFormat variables imageContent + pure [ImageBlock renderedImage] + +imageContentInputVariables :: TemplateFormat -> ImageContent -> [Text] +imageContentInputVariables templateFormat ImageContent {imageSource = source, imageDetail = detail, imageMetadata = metadata} = + imageSourceInputVariables templateFormat source + <> maybe [] (Prompt.extractTemplateVariablesWithFormat templateFormat) detail + <> maybe [] (valueInputVariables templateFormat) metadata + +imageSourceInputVariables :: TemplateFormat -> ImageSource -> [Text] +imageSourceInputVariables templateFormat (ImageBase64 _ imageTemplate) = + Prompt.extractTemplateVariablesWithFormat templateFormat imageTemplate +imageSourceInputVariables templateFormat (ImageUrl url) = + Prompt.extractTemplateVariablesWithFormat templateFormat url + +partialImageContent :: TemplateFormat -> Map.Map Text Text -> ImageContent -> ImageContent +partialImageContent templateFormat partials ImageContent {imageSource = source, imageDetail = detail, imageMetadata = metadata} = + ImageContent + { imageSource = partialImageSource templateFormat partials source + , imageDetail = renderPartial templateFormat partials <$> detail + , imageMetadata = renderPartialValue templateFormat partials <$> metadata + } + +partialImageSource :: TemplateFormat -> Map.Map Text Text -> ImageSource -> ImageSource +partialImageSource templateFormat partials (ImageBase64 mime imageTemplate) = + ImageBase64 mime $ renderPartial templateFormat partials imageTemplate +partialImageSource templateFormat partials (ImageUrl url) = + ImageUrl $ renderPartial templateFormat partials url + +renderImageContent :: + TemplateFormat -> Map.Map Text Text -> ImageContent -> Either LangchainError ImageContent +renderImageContent templateFormat variables ImageContent {imageSource = source, imageDetail = detail, imageMetadata = metadata} = do + renderedSource <- renderImageSource templateFormat variables source + renderedDetail <- traverse (renderTemplate templateFormat variables) detail + renderedMetadata <- traverse (renderValue templateFormat variables) metadata + pure $ ImageContent renderedSource renderedDetail renderedMetadata + +renderImageSource :: + TemplateFormat -> Map.Map Text Text -> ImageSource -> Either LangchainError ImageSource +renderImageSource templateFormat variables (ImageBase64 mime imageTemplate) = + ImageBase64 mime <$> renderTemplate templateFormat variables imageTemplate +renderImageSource templateFormat variables (ImageUrl url) = + ImageUrl <$> renderTemplate templateFormat variables url + +renderTemplate :: TemplateFormat -> Map.Map Text Text -> Text -> Either LangchainError Text +renderTemplate templateFormat variables template = + Prompt.renderPrompt + (Prompt.fromTemplateWithFormat template templateFormat Map.empty) + variables + +renderPartial :: TemplateFormat -> Map.Map Text Text -> Text -> Text +renderPartial templateFormat partials template = + fromRight template $ renderTemplate templateFormat partials template + +valueInputVariables :: TemplateFormat -> Value -> [Text] +valueInputVariables templateFormat (String value) = + Prompt.extractTemplateVariablesWithFormat templateFormat value +valueInputVariables templateFormat (Array values) = + concatMap (valueInputVariables templateFormat) values +valueInputVariables templateFormat (Object objectValue) = + concatMap (valueInputVariables templateFormat) objectValue +valueInputVariables _ _ = [] + +renderValue :: TemplateFormat -> Map.Map Text Text -> Value -> Either LangchainError Value +renderValue templateFormat variables (String value) = + String <$> renderTemplate templateFormat variables value +renderValue templateFormat variables (Array values) = + Array <$> traverse (renderValue templateFormat variables) values +renderValue templateFormat variables (Object objectValue) = + Object <$> traverse (renderValue templateFormat variables) objectValue +renderValue _ _ value = Right value + +renderPartialValue :: TemplateFormat -> Map.Map Text Text -> Value -> Value +renderPartialValue templateFormat partials value = + fromRight value $ renderValue templateFormat partials value + +unique :: [Text] -> [Text] +unique = foldl addIfMissing [] + where + addIfMissing :: [Text] -> Text -> [Text] + addIfMissing variableNames name + | name `elem` variableNames = variableNames + | otherwise = variableNames <> [name] diff --git a/src/Langchain/PromptTemplate/Chat/MessagesPlaceholder.hs b/src/Langchain/PromptTemplate/Chat/MessagesPlaceholder.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/PromptTemplate/Chat/MessagesPlaceholder.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Langchain.PromptTemplate.Chat.MessagesPlaceholder +Description : MessagesPlaceholder prompt template +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +-} +module Langchain.PromptTemplate.Chat.MessagesPlaceholder + ( MessagesPlaceholder (..) + , MessagesPlaceholderOptions (..) + , messagesPlaceholder + , messagesPlaceholderOptions + , messagesPlaceholderWithOptions + , messagesPlaceholderVariableName + ) where + +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import GHC.Generics (Generic) + +import Langchain.Core.Error (validationError) +import Langchain.Core.Model.Types (Message) +import Langchain.PromptTemplate.Chat (BaseMessagePromptTemplate (..)) + +-- | Prompt template that expects one variable to contain an existing message list. +data MessagesPlaceholder = MessagesPlaceholder + { variableName :: Text + , optional :: Bool + , nMessages :: Maybe Int + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +data MessagesPlaceholderOptions = MessagesPlaceholderOptions + { variableName :: Text + , optional :: Bool + , nMessages :: Maybe Int + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +instance BaseMessagePromptTemplate MessagesPlaceholder (Map.Map Text [Message]) where + formatMessages + MessagesPlaceholder + { variableName = variableName' + , optional = optional' + , nMessages = nMessages' + } + inputs = do + values <- + case Map.lookup variableName' inputs of + Just values' -> Right values' + Nothing + | optional' -> Right [] + | otherwise -> + Left $ + validationError + ("Missing variable: " <> variableName') + (Just variableName') + Nothing + case nMessages' of + Just limit + | limit <= 0 -> + Left $ validationError "n_messages must be positive" (Just variableName') Nothing + _ -> pure $ maybe values (`takeLast` values) nMessages' + +-- | Create a required messages placeholder. +messagesPlaceholder :: Text -> MessagesPlaceholder +messagesPlaceholder name = messagesPlaceholderWithOptions $ messagesPlaceholderOptions name + +messagesPlaceholderOptions :: Text -> MessagesPlaceholderOptions +messagesPlaceholderOptions name = + MessagesPlaceholderOptions + { variableName = name + , optional = False + , nMessages = Nothing + } + +messagesPlaceholderWithOptions :: MessagesPlaceholderOptions -> MessagesPlaceholder +messagesPlaceholderWithOptions MessagesPlaceholderOptions {variableName = name, optional = optional', nMessages = nMessages'} = + MessagesPlaceholder + { variableName = name + , optional = optional' + , nMessages = nMessages' + } + +messagesPlaceholderVariableName :: MessagesPlaceholder -> Text +messagesPlaceholderVariableName MessagesPlaceholder {variableName = name} = name + +takeLast :: Int -> [a] -> [a] +takeLast n values = drop (max 0 (length values - n)) values diff --git a/src/Langchain/PromptTemplate/FewShot.hs b/src/Langchain/PromptTemplate/FewShot.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/PromptTemplate/FewShot.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.PromptTemplate.FewShot +Description : Few-shot prompt templates +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +-} +module Langchain.PromptTemplate.FewShot + ( FewShotPromptTemplate (..) + , renderFewShotPrompt + , renderFewShotPromptWithVars + ) where + +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T + +import Langchain.Core.Error (LangchainError) +import Langchain.PromptTemplate.Prompt (fromTemplate, renderPrompt) + +-- | Represents a few-shot prompt template with examples +data FewShotPromptTemplate = FewShotPromptTemplate + { fsPrefix :: Text + , fsExamples :: [Map.Map Text Text] + , fsExampleTemplate :: Text + , fsExampleSeparator :: Text + , fsSuffix :: Text + } + deriving (Show, Eq) + +-- | Render a few-shot prompt template +renderFewShotPrompt :: FewShotPromptTemplate -> Either LangchainError Text +renderFewShotPrompt FewShotPromptTemplate {..} = do + formattedExamples <- traverse (renderPrompt (fromTemplate fsExampleTemplate)) fsExamples + let examplesText = T.intercalate fsExampleSeparator formattedExamples + pure $ fsPrefix <> examplesText <> fsSuffix + +-- | Render few-shot template with additional variables +renderFewShotPromptWithVars :: + FewShotPromptTemplate -> Map.Map Text Text -> Either LangchainError Text +renderFewShotPromptWithVars template vars = do + renderedBase <- renderFewShotPrompt template + renderPrompt (fromTemplate renderedBase) vars diff --git a/src/Langchain/PromptTemplate/Prompt.hs b/src/Langchain/PromptTemplate/Prompt.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/PromptTemplate/Prompt.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module : Langchain.PromptTemplate.Prompt +Description : String prompt templates +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Prompt templates backed by string interpolation. +-} +module Langchain.PromptTemplate.Prompt + ( PromptTemplate (..) + , PromptTemplateOptions (..) + , TemplateFormat (..) + , defaultPromptTemplateOptions + , fromTemplate + , fromTemplateWithOptions + , fromTemplateWithFormat + , partialPromptTemplate + , renderPrompt + , renderTemplateWithFormat + , renderFStringTemplate + , extractTemplateVariables + , extractTemplateVariablesWithFormat + ) where + +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import GHC.Generics (Generic) + +import Langchain.Core.Error (LangchainError) +import Langchain.Core.Runnable (Runnable (..)) +import Langchain.PromptTemplate.String + ( TemplateFormat (..) + , extractTemplateVariables + , extractTemplateVariablesWithFormat + , renderFStringTemplate + , renderTemplateWithFormat + ) + +-- | Prompt template container with template string containing {var} placeholders. +data PromptTemplate = PromptTemplate + { template :: Text + , inputVariables :: [Text] + , -- Matches Python partial_variables: pre-bound values reduce required inputs + -- without changing the original template string. + partialVariables :: Map.Map Text Text + , templateFormat :: TemplateFormat + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | Options for building a prompt template, currently only partial variables. +newtype PromptTemplateOptions = PromptTemplateOptions + { partialVariables :: Map.Map Text Text + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | Default prompt template options with no partial variables. +defaultPromptTemplateOptions :: PromptTemplateOptions +defaultPromptTemplateOptions = PromptTemplateOptions mempty + +-- | Build a string prompt template using the default FString format. +fromTemplate :: Text -> PromptTemplate +fromTemplate source = fromTemplateWithOptions source defaultPromptTemplateOptions + +-- | Build a string prompt template with pre-bound partial variables. +fromTemplateWithOptions :: Text -> PromptTemplateOptions -> PromptTemplate +fromTemplateWithOptions source (PromptTemplateOptions partials) = + fromTemplateWithFormat source FString partials + +-- | Build a prompt template from raw text, format, and partial variables. +fromTemplateWithFormat :: Text -> TemplateFormat -> Map.Map Text Text -> PromptTemplate +fromTemplateWithFormat source format partials = + PromptTemplate + { template = source + , inputVariables = + filter (`Map.notMember` partials) (extractTemplateVariablesWithFormat format source) + , partialVariables = partials + , templateFormat = format + } + +-- | Apply additional partial variables to an existing prompt template. +partialPromptTemplate :: PromptTemplate -> Map.Map Text Text -> PromptTemplate +partialPromptTemplate (PromptTemplate source _ existingPartials format) partials = + fromTemplateWithFormat source format (partials `Map.union` existingPartials) + +-- | Render a prompt template with the given variable map. +renderPrompt :: PromptTemplate -> Map.Map Text Text -> Either LangchainError Text +renderPrompt (PromptTemplate source _ partials format) vars = + renderTemplateWithFormat format (vars `Map.union` partials) source + +-- | 'PromptTemplate' implements 'Runnable' transforming variable 'Map' to rendered 'Text'. +instance Monad m => Runnable PromptTemplate m where + type RunnableInput PromptTemplate = Map.Map Text Text + type RunnableOutput PromptTemplate = Text + invoke pt vars = pure (renderPrompt pt vars) diff --git a/src/Langchain/PromptTemplate/String.hs b/src/Langchain/PromptTemplate/String.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/PromptTemplate/String.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Langchain.PromptTemplate.String +Description : String prompt template formatting helpers +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +String template parsing, variable extraction, and interpolation helpers. +-} +module Langchain.PromptTemplate.String + ( TemplateFormat (..) + , renderTemplateWithFormat + , renderFStringTemplate + , extractTemplateVariables + , extractTemplateVariablesWithFormat + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Char (isDigit) +import Data.Foldable (traverse_) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Format.Heavy.Build (formatEither) +import Data.Text.Format.Heavy.Instances () +import Data.Text.Format.Heavy.Parse (FormatParseItem (..), parse, parseFormat) +import qualified Data.Text.Lazy as TL +import GHC.Generics (Generic) + +import Langchain.Core.Error (LangchainError, validationError) + +data TemplateFormat + = FString + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +renderTemplateWithFormat :: + TemplateFormat -> Map.Map Text Text -> Text -> Either LangchainError Text +renderTemplateWithFormat FString = renderFStringTemplate + +renderFStringTemplate :: Map.Map Text Text -> Text -> Either LangchainError Text +renderFStringTemplate vars source = do + items <- parseFStringTemplate source + traverse_ validateFStringItem items + format <- mapParseError $ parseFormat (TL.fromStrict source) + mapFormatError $ TL.toStrict <$> formatEither format (toFStringVars vars) + where + mapFormatError :: Either String a -> Either LangchainError a + mapFormatError (Left err) = Left $ validationError (T.pack err) (Just "PromptTemplate") Nothing + mapFormatError (Right result) = Right result + +toFStringVars :: Map.Map Text Text -> Map.Map TL.Text Text +toFStringVars = Map.mapKeys TL.fromStrict + +parseFStringTemplate :: Text -> Either LangchainError [FormatParseItem] +parseFStringTemplate source = mapParseError $ parse (TL.fromStrict source) + +mapParseError :: (Show err) => Either err a -> Either LangchainError a +mapParseError (Left err) = Left $ validationError (T.pack $ show err) (Just "PromptTemplate") Nothing +mapParseError (Right result) = Right result + +validateFStringItem :: FormatParseItem -> Either LangchainError () +validateFStringItem (FormatString _) = Right () +validateFStringItem (FormatReplacementField variableName formatSpec) = do + validateFStringVariableName variableName + traverse_ validateFStringFormatSpec formatSpec + +validateFStringVariableName :: TL.Text -> Either LangchainError () +validateFStringVariableName variableName + | TL.all isDigit variableName = + Left $ + validationError "Positional arguments are not supported" (Just $ TL.toStrict variableName) Nothing + | TL.any (== '.') variableName = + Left $ validationError "Attribute access is not supported" (Just $ TL.toStrict variableName) Nothing + | TL.any (`elem` ['[', ']']) variableName = + Left $ validationError "Index access is not supported" (Just $ TL.toStrict variableName) Nothing + | otherwise = Right () + +validateFStringFormatSpec :: TL.Text -> Either LangchainError () +validateFStringFormatSpec formatSpec + | TL.any (`elem` ['{', '}']) formatSpec = + Left $ validationError "Nested replacement fields are not allowed" (Just "PromptTemplate") Nothing + | otherwise = Right () + +extractTemplateVariables :: Text -> [Text] +extractTemplateVariables = extractTemplateVariablesWithFormat FString + +extractTemplateVariablesWithFormat :: TemplateFormat -> Text -> [Text] +extractTemplateVariablesWithFormat FString source = + case parseFStringTemplate source of + Left _ -> [] + Right parts -> unique [TL.toStrict variableName | FormatReplacementField variableName _ <- parts] + +unique :: [Text] -> [Text] +unique = foldl addIfMissing [] + +addIfMissing :: [Text] -> Text -> [Text] +addIfMissing variableNames variableName + | variableName `elem` variableNames = variableNames + | otherwise = variableNames <> [variableName] diff --git a/src/Langchain/Provider/Gemini.hs b/src/Langchain/Provider/Gemini.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Provider/Gemini.hs @@ -0,0 +1,483 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{- | +Module : Langchain.Provider.Gemini +Description : Google Gemini provider implementing ChatModel +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Gemini provider with multi-modal content parts support. +-} +module Langchain.Provider.Gemini + ( Gemini (..) + , GeminiConfig (..) + , defaultConfig + , defaultGeminiConfig + , newGemini + , parseGeminiResponse + ) where + +import Control.Applicative ((<|>)) +import Control.Concurrent.Async (AsyncCancelled (..)) +import Control.Exception (SomeException, fromException, throwIO, try) +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson +import qualified Data.Aeson.KeyMap as KeyMap +import Data.Aeson.Types (Parser, parseEither) +import Data.Conduit (ConduitT, await, runConduit, yield, (.|)) +import qualified Data.Conduit.Combinators as C +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import qualified Data.Proxy as Proxy +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) +import Network.HTTP.Client (newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.HTTP.Simple +import Servant.API (Capture, JSON, QueryParam, ReqBody, (:>)) +import Servant.API.EventStream + ( FromServerEvent (fromServerEvent) + , PostServerSentEvents + , jsonData + ) +import Servant.Client.Core.BaseUrl (parseBaseUrl) +import Servant.Client.Streaming (ClientM, client, mkClientEnv, withClientM) +import Servant.Conduit () + +import Langchain.Core.Error (LangchainError, llmError) +import Langchain.Core.Model +import Langchain.Core.Stream (StreamEvent (..), TokenUsage (..), callbackSource) +import qualified Langchain.Core.Tool as CoreTool +import Langchain.Tool.Binding (ToolBinder (..)) + +-- | Gemini configuration +data GeminiConfig = GeminiConfig + { configApiKey :: Text + , configModel :: Text + } + deriving (Eq, Show, Generic, ToJSON, FromJSON) + +defaultConfig :: Text -> GeminiConfig +defaultConfig key = GeminiConfig key "gemini-2.0-flash" + +defaultGeminiConfig :: Text -> GeminiConfig +defaultGeminiConfig = defaultConfig + +-- | Gemini ChatModel provider +data Gemini + = Gemini + { apiKey :: Text + , model :: Text + , baseUrl :: Maybe Text + } + deriving (Eq, Show) + +-- | Create a new Gemini provider instance +newGemini :: Text -> Text -> Maybe Text -> Gemini +newGemini = Gemini + +geminiApiKey :: Gemini -> Text +geminiApiKey = apiKey + +geminiModel :: Gemini -> Text +geminiModel = model + +geminiBaseUrl :: Gemini -> Text +geminiBaseUrl Gemini {baseUrl = Just baseUrl} = T.dropWhileEnd (== '/') baseUrl +geminiBaseUrl Gemini {} = "https://generativelanguage.googleapis.com" + +-- Convert ContentBlock to Gemini Part JSON +contentBlockToPart :: ContentBlock -> Value +contentBlockToPart (TextBlock t) = + object ["text" .= t] +contentBlockToPart (ImageBlock ImageContent {imageSource = ImageBase64 (Just mime) b64}) = + object + [ "inline_data" + .= object + [ "mime_type" .= mime + , "data" .= b64 + ] + ] +contentBlockToPart (ImageBlock ImageContent {imageSource = ImageUrl url}) = + object ["text" .= ("[Image URL: " <> url <> "]")] +contentBlockToPart (ImageBlock ImageContent {imageSource = ImageBase64 Nothing _}) = + object ["text" .= ("[Image data block: base64]" :: Text)] +contentBlockToPart (AudioBlock mime b64) = + object + [ "inline_data" + .= object + [ "mime_type" .= mime + , "data" .= b64 + ] + ] +contentBlockToPart (DataBlock _) = + object ["text" .= ("[Data block]" :: Text)] + +-- Convert a non-tool Message to Gemini Content JSON. +messageToGemini :: Message -> Value +messageToGemini msg = + let role = messageRole msg + geminiRole = case role of + User -> "user" + Assistant -> "model" + System -> "user" + Developer -> "user" + Tool -> "user" + Function -> "user" + toolCallParts = case role of + Assistant -> maybe [] (functionCallParts $ messageMetadata msg) (messageToolCalls msg) + _ -> [] + contentBlocks = NonEmpty.toList (messageContents msg) + contentParts = map contentBlockToPart contentBlocks + parts + | null toolCallParts = contentParts + | otherwise = map contentBlockToPart (filter (not . emptyTextPart) contentBlocks) <> toolCallParts + in object ["role" .= (geminiRole :: Text), "parts" .= parts] + where + functionCallParts metadata toolCalls = + zipWith functionCallPart toolCalls (thoughtSignatures metadata <> repeat Nothing) + + functionCallPart (ToolCall {toolCallName = name, toolCallArguments = args, toolCallId = callId}) thoughtSignature = + object $ + [ "functionCall" + .= object + ( [ "name" .= name + , "args" .= args + ] + <> (["id" .= callId | notNull callId]) + ) + ] + <> maybe [] (pure . ("thoughtSignature" .=)) thoughtSignature + + notNull = not . T.null + + emptyTextPart (TextBlock text) = T.null text + emptyTextPart _ = False + +geminiThoughtSignaturesKey :: Text +geminiThoughtSignaturesKey = "langchain.gemini.thoughtSignatures" + +thoughtSignatures :: Map.Map Text Value -> [Maybe Text] +thoughtSignatures metadata = + case Map.lookup geminiThoughtSignaturesKey metadata of + Just value -> case fromJSON value of + Success signatures -> signatures + Error _ -> [] + Nothing -> [] + +withThoughtSignatures :: [ToolCall] -> [Maybe Text] -> Message -> Message +withThoughtSignatures [] _ message = message {messageToolCalls = Nothing} +withThoughtSignatures toolCalls signatures message = + message + { messageToolCalls = Just toolCalls + , messageMetadata = + Map.insert geminiThoughtSignaturesKey (toJSON signatures) (messageMetadata message) + } + +functionResponsePart :: [ToolCall] -> Message -> Either Text Value +functionResponsePart priorToolCalls msg = do + toolName <- + maybe + (Left "Gemini function response is missing a function name") + Right + (messageName msg <|> (messageToolId msg >>= lookupToolName)) + let functionResponseFields = + [ "name" .= toolName + , "response" .= object ["result" .= extractMessageText msg] + ] + <> maybe [] (pure . ("id" .=)) (messageToolId msg) + pure $ object ["functionResponse" .= object functionResponseFields] + where + lookupToolName toolId = + toolCallName <$> List.find ((== toolId) . toolCallId) priorToolCalls + +messagesToGemini :: [ToolCall] -> [Message] -> Either Text [Value] +messagesToGemini _ [] = Right [] +messagesToGemini priorToolCalls (msg : remaining) + | isFunctionResponse msg = do + let (responseMessages, followingMessages) = span isFunctionResponse remaining + parts <- traverse (functionResponsePart priorToolCalls) (msg : responseMessages) + contents <- messagesToGemini priorToolCalls followingMessages + pure $ object ["role" .= ("user" :: Text), "parts" .= parts] : contents + | otherwise = do + contents <- messagesToGemini priorToolCalls remaining + pure $ messageToGemini msg : contents + where + isFunctionResponse message = messageRole message `elem` [Tool, Function] + +geminiRequestPayload :: [Message] -> Maybe Value -> Either Text Value +geminiRequestPayload inputMsgs config = do + let priorToolCalls = concatMap (fromMaybe [] . messageToolCalls) inputMsgs + contents <- messagesToGemini priorToolCalls inputMsgs + case config of + Just (Object fields) -> pure $ Object $ KeyMap.insert "contents" (toJSON contents) fields + Nothing -> pure $ object ["contents" .= contents] + Just _ -> Left "Gemini config must be a JSON object" + +instance ChatModel Gemini where + type ModelConfig Gemini = Value + + invoke provider inputMsgs config = do + payload <- + either (throwError . \err -> llmError err Nothing Nothing) pure $ + geminiRequestPayload inputMsgs config + let url = + geminiBaseUrl provider + <> "/v1beta/models/" + <> geminiModel provider + <> ":generateContent?key=" + <> geminiApiKey provider + initReq = parseRequest_ (T.unpack url) + req = + setRequestMethod "POST" $ + setRequestHeader "Content-Type" ["application/json"] $ + setRequestBodyJSON payload initReq + + eRes <- liftIO $ safeHttpRequest req + case eRes of + Left err -> throwError $ llmError err Nothing Nothing + Right bodyVal -> case parseGeminiResponse bodyVal of + Left parseErr -> throwError $ llmError (T.pack parseErr) Nothing Nothing + Right respMsg -> pure respMsg + + stream provider inputMsgs config = do + let model = geminiModel provider + requestPayload = geminiRequestPayload inputMsgs + yield $ LLMStart rId model inputMsgs + + payload <- + either (throwError . llmError') pure $ requestPayload config + + let events = geminiEvents payload + (accumulated, toolCalls, thoughtSignatures', usage) <- + callbackSource events + .| receiveChunks "" [] [] Nothing + + let message = withThoughtSignatures toolCalls thoughtSignatures' $ assistantMessage accumulated + yield $ LLMEnd rId message usage + where + receiveChunks accumulated toolCalls thoughtSignatures' usage = do + next <- await + case next of + Nothing -> pure (accumulated, toolCalls, thoughtSignatures', usage) + Just (Left err) -> throwError $ llmError' err + Just (Right (GeminiStreamEvent GeminiStreamChunk {streamCandidates, streamUsage})) -> do + let parts = maybe [] streamParts $ candidate0 streamCandidates + texts = [text | GeminiText text <- parts] + calls = [(toolCall, signature) | GeminiFunctionCall toolCall signature <- parts] + nextUsage = streamUsage <|> usage + emitParts texts (map fst calls) + receiveChunks + (accumulated <> mconcat texts) + (toolCalls <> map fst calls) + (thoughtSignatures' <> map snd calls) + nextUsage + + candidate0 = List.find ((== 0) . streamCandidateIndex) + + emitParts texts [] = mapM_ (`yieldChunk` Nothing) texts + emitParts texts (toolCall : remaining) = do + yieldChunk (mconcat texts) (Just toolCall) + mapM_ (yieldChunk "" . Just) remaining + + yieldChunk text mbToolCall = yield $ LLMChunk rId text mbToolCall + + geminiEvents requestPayload emit = do + result <- try $ do + manager <- newManager tlsManagerSettings + + let baseUrl = parseBaseUrl (T.unpack $ geminiBaseUrl provider) + model = geminiModel provider + apiKey = geminiApiKey provider + request = + geminiStreamClient + (model <> ":streamGenerateContent") + (Just "sse") + (Just apiKey) + requestPayload + + clientEnv <- mkClientEnv manager <$> baseUrl + withClientM request clientEnv $ + either + emitError + (\source -> runConduit $ source .| C.mapM_ (emit . Right)) + case result of + Left err + | Just AsyncCancelled <- fromException err -> throwIO err + | otherwise -> emitError err + Right () -> pure () + where + emitError :: Show a => a -> IO () + emitError = + emit . Left . redactKey (geminiApiKey provider) . T.pack . show + + rId = "gemini-stream-run" + +llmError' :: Text -> LangchainError +llmError' err = llmError err Nothing Nothing + +{- | Replace the literal API key with @[REDACTED]@ in error messages so it + never appears in 'LangchainError' values or test output. +-} +redactKey :: Text -> Text -> Text +redactKey key txt + | T.null key = txt + | otherwise = T.replace key "[REDACTED]" txt + +data GeminiStreamChunk = GeminiStreamChunk + { streamCandidates :: [GeminiStreamCandidate] + , streamUsage :: Maybe TokenUsage + } + +instance FromJSON GeminiStreamChunk where + parseJSON = withObject "GeminiStreamChunk" $ \obj -> + GeminiStreamChunk + <$> obj .:? "candidates" .!= [] + <*> (obj .:? "usageMetadata" >>= traverse parseGeminiUsage) + +data GeminiStreamCandidate = GeminiStreamCandidate + { streamCandidateIndex :: Int + , streamParts :: [GeminiPart] + } + +instance FromJSON GeminiStreamCandidate where + parseJSON = withObject "GeminiStreamCandidate" $ \obj -> do + streamCandidateIndex <- obj .:? "index" .!= 0 + content <- obj .:? "content" + streamParts <- case content of + Nothing -> pure [] + Just contentValue -> withObject "GeminiStreamContent" parseParts contentValue + pure GeminiStreamCandidate {streamCandidateIndex, streamParts} + where + parseParts contentObj = do + parts <- contentObj .:? "parts" .!= [] + traverse parseGeminiPart parts + +data GeminiPart + = GeminiText Text + | GeminiFunctionCall ToolCall (Maybe Text) + +parseGeminiPart :: Value -> Parser GeminiPart +parseGeminiPart = withObject "GeminiPart" $ \obj -> do + functionCall <- obj .:? "functionCall" + case functionCall of + Just value -> GeminiFunctionCall <$> parseGeminiFunctionCall value <*> pure (parseThoughtSignature obj) + Nothing -> GeminiText <$> obj .:? "text" .!= "" + +parseGeminiFunctionCall :: Value -> Parser ToolCall +parseGeminiFunctionCall = withObject "GeminiFunctionCall" $ \obj -> + ToolCall + <$> obj .:? "id" .!= "" + <*> pure "function" + <*> obj .: "name" + <*> obj .:? "args" .!= object [] + +parseThoughtSignature :: Object -> Maybe Text +parseThoughtSignature obj = + case KeyMap.lookup "thoughtSignature" obj of + Just (String signature) -> Just signature + _ -> Nothing + +parseGeminiUsage :: Value -> Parser TokenUsage +parseGeminiUsage = withObject "GeminiUsageMetadata" $ \obj -> + TokenUsage + <$> obj .:? "promptTokenCount" .!= 0 + <*> obj .:? "candidatesTokenCount" .!= 0 + <*> obj .:? "totalTokenCount" .!= 0 + +newtype GeminiStreamEvent = GeminiStreamEvent GeminiStreamChunk + +instance FromServerEvent GeminiStreamEvent where + fromServerEvent event = GeminiStreamEvent <$> jsonData event + +type GeminiStreamApi = + "v1beta" + :> "models" + :> Capture "modelAction" Text + :> QueryParam "alt" Text + :> QueryParam "key" Text + :> ReqBody '[JSON] Value + :> PostServerSentEvents (ConduitT () GeminiStreamEvent IO ()) + +geminiStreamClient :: + Text -> Maybe Text -> Maybe Text -> Value -> ClientM (ConduitT () GeminiStreamEvent IO ()) +geminiStreamClient = client (Proxy.Proxy :: Proxy.Proxy GeminiStreamApi) + +-- Helper for HTTP requests +safeHttpRequest :: Request -> IO (Either Text Value) +safeHttpRequest req = do + eRes <- + try (httpJSONEither req) :: IO (Either SomeException (Response (Either JSONException Value))) + case eRes of + Left ex -> pure $ Left (T.pack $ show ex) + Right res -> case getResponseBody res of + Left err -> pure $ Left (T.pack $ show err) + Right val -> pure $ Right val + +-- Parse Gemini response JSON +parseGeminiResponse :: Value -> Either String Message +parseGeminiResponse = parseEither $ withObject "GeminiResponse" $ \o -> do + -- Surface API-level errors (e.g. safety blocks, quota exhausted) verbatim + case KeyMap.lookup "error" o of + Just (Object errObj) -> do + msg <- errObj .: "message" <|> pure "Unknown Gemini API error" + fail (T.unpack msg) + _ -> pure () + candidates <- o .: "candidates" + case candidates of + [] -> fail "Empty candidates array in Gemini response" + (c : _) -> + flip (withObject "Candidate") c $ \cand -> do + -- "content" is absent when finishReason is SAFETY or MAX_TOKENS with no output + mContentObj <- cand .:? "content" + case mContentObj of + Nothing -> pure $ assistantMessage "" + Just contentObj -> do + parts <- contentObj .: "parts" + parsedParts <- traverse parseGeminiPart parts + let texts = [text | GeminiText text <- parsedParts] + toolCalls = [toolCall | GeminiFunctionCall toolCall _ <- parsedParts] + signatures = [signature | GeminiFunctionCall _ signature <- parsedParts] + pure $ + withThoughtSignatures toolCalls signatures $ + assistantMessage $ + T.intercalate "\n" texts + +-- | Bind tools to a Gemini model by adding function declarations to the config. +instance ToolBinder Gemini m where + bindToolsConfig tools config = + case tools of + [] -> config + _ -> + let generated = + KeyMap.singleton + "tools" + ( toJSON + [ object ["functionDeclarations" .= map functionDeclaration tools] + ] + ) + in Just $ case config of + Nothing -> Object generated + Just (Object existing) -> Object (KeyMap.union generated existing) + Just other -> other + where + functionDeclaration tool = + object + [ "name" .= CoreTool.toolName tool + , "description" .= CoreTool.toolDescription tool + , "parameters" .= CoreTool.toolSchema tool + ] diff --git a/src/Langchain/Provider/Ollama.hs b/src/Langchain/Provider/Ollama.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Provider/Ollama.hs @@ -0,0 +1,396 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module : Langchain.Provider.Ollama +Description : Ollama provider implementing the effect-polymorphic ChatModel typeclass +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Ollama provider using 'ollama-haskell' 0.4.0.0. Supports native structured outputs +via JSON Schema grammar sampling, streaming, tool calling, and embeddings. + +== Request & Precedence Semantics +Because Ollama's 'ModelConfig' is 'OllamaChat.ChatRequest', which contains both +'chatModel' and 'chatMessages', callers may supply messages and model names either +via the 'ChatModel' interface ('invoke' / 'stream' arguments) or within the 'ChatRequest'. + +The provider resolves these with well-defined precedence rules: + +1. __Messages Precedence__: + * When @inputMsgs@ is non-empty (@not (null inputMsgs)@), it takes precedence over + 'ChatRequest.chatMessages'. This enables reusing request templates across multiple calls + and ensures 'batch' processes each item's messages properly. + * When @inputMsgs@ is empty (@null inputMsgs@), the provider falls back to + 'ChatRequest.chatMessages' if a 'ChatRequest' is provided. + * If both are empty, defaults to an empty user message. + +2. __Model Name Precedence__: + * When a 'ChatRequest' is provided with a non-empty 'chatModel', it overrides + the provider's default 'ollamaModelName'. + * Otherwise, the provider's 'ollamaModelName' is used as the default. +-} +module Langchain.Provider.Ollama + ( Ollama (..) + , newOllama + , newOllamaWithClient + , toOllamaRole + , fromOllamaRole + , toOllamaMessage + , fromOllamaMessage + , withJsonFormat + , withSchemaFormat + , withStructuredOutput + , withOptions + , chatRequestFor + , resolveChatRequest + , withTools + , toOllamaTool + , toOllamaTools + , OllamaWithTools (..) + , bindTools + + -- * Re-exports from ollama-haskell format, schema, options & client config + , module Ollama.API.Chat + , module Ollama.Client.Config + , module Ollama.Types.Common + , module Ollama.Types.Options + , OFormat.Format (..) + , OSB.Schema (..) + , OSB.Property (..) + , OSB.JsonType (..) + , OSD.ToSchema (..) + , OSD.ToJsonType (..) + ) where + +import Control.Monad (when) +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (Result (..), decode, fromJSON, toJSON) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy.Char8 as LBSC +import Data.Conduit (await, transPipe, yield, (.|)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (fromMaybe, isJust, mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +import Langchain.Core.Error (llmError) +import Langchain.Core.Model +import Langchain.Core.Stream (StreamEvent (..), TokenUsage (..)) +import Langchain.Core.Tool (Tool, toolToValue) +import Langchain.Tool.Binding (ToolBinder (..)) + +import Ollama.API.Chat +import qualified Ollama.API.Chat as OllamaChat +import Ollama.Client (OllamaClient, newClient) +import Ollama.Client.Config +import Ollama.Types.Common (Base64Image (..), ModelName (..)) +import qualified Ollama.Types.Format as OFormat +import qualified Ollama.Types.Format.SchemaBuilder as OSB +import qualified Ollama.Types.Format.SchemaDerive as OSD +import qualified Ollama.Types.Message as O +import Ollama.Types.Options (ModelOptions (..), defaultOptions) +import qualified Ollama.Types.Tool as OTool + +-- | Ollama provider data type wrapping OllamaClient and model name +data Ollama = Ollama + { client :: OllamaClient + , ollamaModelName :: Text + } + +instance Show Ollama where + show (Ollama _ m) = "Ollama provider (" ++ show m ++ ")" + +-- | Create a new Ollama provider with model name and client config +newOllama :: MonadIO m => Text -> OllamaClientConfig -> m Ollama +newOllama model cfg = do + c <- liftIO $ newClient cfg + pure $ Ollama c model + +-- | Create an Ollama provider using an existing OllamaClient handle +newOllamaWithClient :: Text -> OllamaClient -> Ollama +newOllamaWithClient model c = Ollama c model + +-- | Helper to convert core Role to Ollama Role +toOllamaRole :: Role -> O.Role +toOllamaRole System = O.System +toOllamaRole User = O.User +toOllamaRole Assistant = O.Assistant +toOllamaRole Tool = O.Tool +toOllamaRole Developer = O.System +toOllamaRole Function = O.Tool + +-- | Helper to convert Ollama Role to core Role +fromOllamaRole :: O.Role -> Role +fromOllamaRole O.System = System +fromOllamaRole O.User = User +fromOllamaRole O.Assistant = Assistant +fromOllamaRole O.Tool = Tool + +-- | Convert core Message to Ollama Message +toOllamaMessage :: Message -> O.Message +toOllamaMessage msg = + let r = toOllamaRole (messageRole msg) + txt = extractMessageText msg + imgs = case [ b64 + | ImageBlock ImageContent {imageSource = ImageBase64 _ b64} <- NonEmpty.toList (messageContents msg) + ] of + [] -> Nothing + xs -> Just (map Base64Image xs) + tools = case messageToolCalls msg of + Nothing -> Nothing + Just tcs -> + Just + [ OTool.ToolCall + { OTool.tcFunction = + OTool.ToolCallFunction + { OTool.tcfName = toolCallName tc + , OTool.tcfArguments = parseArgs (toolCallArguments tc) + } + } + | tc <- tcs + ] + parseArgs v = case v of + Aeson.Object _ -> case fromJSON v of + Success m -> m + _ -> mempty + Aeson.String s -> fromMaybe mempty $ decode (LBSC.fromStrict (TE.encodeUtf8 s)) + _ -> case fromJSON v of + Success m -> m + _ -> mempty + in O.Message r txt imgs tools (messageName msg) Nothing + +-- | Convert Ollama Message to core Message +fromOllamaMessage :: O.Message -> Message +fromOllamaMessage (O.Message r txt _imgs tools name _think) = + let cRole = fromOllamaRole r + cMsg = (textMessage cRole txt) {messageName = name} + cTools = case tools of + Nothing -> Nothing + Just tcs -> + Just + [ ToolCall + { toolCallId = "" + , toolCallType = "function" + , toolCallName = OTool.tcfName (OTool.tcFunction tc) + , toolCallArguments = toJSON (OTool.tcfArguments (OTool.tcFunction tc)) + } + | tc <- tcs + ] + in cMsg {messageToolCalls = cTools} + +{- | Construct a 'ChatRequest' for an 'Ollama' instance with the given messages. + +Sets 'chatModel' to the provider's 'ollamaModelName'. When passed to 'invoke' +or 'stream', any non-empty message argument passed directly to 'invoke' or +'stream' will take priority over the messages in this 'ChatRequest'. +-} +chatRequestFor :: Ollama -> [Message] -> OllamaChat.ChatRequest +chatRequestFor model inputMsgs = + let oMsgs = case inputMsgs of + [] -> O.userMessage "" NonEmpty.:| [] + (m : ms) -> NonEmpty.map toOllamaMessage (m NonEmpty.:| ms) + in OllamaChat.chatRequest (ModelName (ollamaModelName model)) oMsgs + +{- | Resolve the effective 'ChatRequest', effective model name, and effective messages +given the provider instance, explicit message arguments, and optional 'ChatRequest'. + += Precedence Rules + +* __Messages Precedence__: + 1. If @inputMsgs@ is non-empty (@not (null inputMsgs)@), it takes priority and + is used as the request conversation. This enables reusing a configured + 'ChatRequest' (tools, formats, options) across invocations and guarantees + that 'batch' processes each item's messages properly. + 2. If @inputMsgs@ is empty (@null inputMsgs@) and a 'ChatRequest' is provided, + its 'chatMessages' field is preserved and used. + 3. If both are empty (or @inputMsgs@ is empty and 'mbReq' is 'Nothing'), + it defaults to a single empty user message. + +* __Model Name Precedence__: + 1. If a 'ChatRequest' is provided and its 'chatModel' is non-empty, + it overrides the provider's default 'ollamaModelName'. + 2. Otherwise, the provider's 'ollamaModelName' is used as the default. +-} +resolveChatRequest :: + Ollama -> + [Message] -> + Maybe OllamaChat.ChatRequest -> + (OllamaChat.ChatRequest, Text, [Message]) +resolveChatRequest model inputMsgs mbReq = + let providerModel = ollamaModelName model + resolvedModelText = case mbReq of + Just r -> + let m = unModelName (OllamaChat.chatModel r) + in if T.null m then providerModel else m + Nothing -> providerModel + resolvedModelName = ModelName resolvedModelText + + (resolvedOMsgs, resolvedCoreMsgs) = case inputMsgs of + (m : ms) -> + let oList = NonEmpty.map toOllamaMessage (m NonEmpty.:| ms) + in (oList, inputMsgs) + [] -> case mbReq of + Just r -> + let oList = OllamaChat.chatMessages r + coreList = map fromOllamaMessage (NonEmpty.toList oList) + in (oList, coreList) + Nothing -> + (O.userMessage "" NonEmpty.:| [], []) + + resolvedReq = case mbReq of + Nothing -> + OllamaChat.chatRequest resolvedModelName resolvedOMsgs + Just r -> + r + { OllamaChat.chatModel = resolvedModelName + , OllamaChat.chatMessages = resolvedOMsgs + } + in (resolvedReq, resolvedModelText, resolvedCoreMsgs) + +instance ChatModel Ollama where + type ModelConfig Ollama = OllamaChat.ChatRequest + + invoke model inputMsgs mbReq = do + let (req, _modelName, _msgs) = resolveChatRequest model inputMsgs mbReq + eRes <- liftIO $ OllamaChat.chat (client model) req + case eRes of + Left err -> throwError $ llmError (T.pack $ show err) Nothing Nothing + Right resp -> case OllamaChat.crMessage resp of + Nothing -> throwError $ llmError "No message in response" Nothing Nothing + Just oMsg -> pure $ fromOllamaMessage oMsg + + stream model inputMsgs mbReq = do + let runId_ = "ollama-run" + (req, resolvedModel, resolvedMsgs) = resolveChatRequest model inputMsgs mbReq + + yield $ LLMStart runId_ resolvedModel resolvedMsgs + transPipe liftIO (OllamaChat.chatStream (client model) req) .| processChunks runId_ + where + processChunks rId = loop [] Nothing Nothing + where + loop accChunks mbLastUsage mbLastTools = + await >>= \case + Nothing -> do + let fullText = T.concat (reverse accChunks) + finalMsg = + (assistantMessage fullText) + { messageToolCalls = mbLastTools + } + yield $ LLMEnd rId finalMsg mbLastUsage + Just resp -> do + let mbMsg = OllamaChat.crMessage resp + chunkTxt = maybe "" O.messageContent mbMsg + mbTools = mbMsg >>= O.messageToolCalls + toolCalls = case mbTools of + Nothing -> Nothing + Just tcs -> + Just + [ ToolCall + { toolCallId = "" + , toolCallType = "function" + , toolCallName = OTool.tcfName (OTool.tcFunction tc) + , toolCallArguments = toJSON (OTool.tcfArguments (OTool.tcFunction tc)) + } + | tc <- tcs + ] + toolDelta = case toolCalls of + Just (tc : _) -> Just tc + _ -> Nothing + newAccChunks = if T.null chunkTxt then accChunks else chunkTxt : accChunks + newTools = case toolCalls of + Just tcs -> Just $ maybe tcs (++ tcs) mbLastTools + Nothing -> mbLastTools + newUsage = case (OllamaChat.crPromptEvalCount resp, OllamaChat.crEvalCount resp) of + (Just p, Just c) -> Just $ TokenUsage p c (p + c) + _ -> mbLastUsage + when (not (T.null chunkTxt) || isJust toolDelta) $ + yield $ + LLMChunk rId chunkTxt toolDelta + loop newAccChunks newUsage newTools + +-- | Set model options on an Ollama ChatRequest +withOptions :: ModelOptions -> OllamaChat.ChatRequest -> OllamaChat.ChatRequest +withOptions opts req = req {OllamaChat.chatOptions = Just opts} + +-- | Attach Langchain tools to an Ollama ChatRequest +withTools :: [Tool m] -> OllamaChat.ChatRequest -> OllamaChat.ChatRequest +withTools ts req = req {OllamaChat.chatTools = Just (toOllamaTools ts)} + +-- | Convert a Langchain 'Tool' definition to an Ollama 'OTool.Tool' +toOllamaTool :: Tool m -> Maybe OTool.Tool +toOllamaTool t = case fromJSON (toolToValue t) of + Success ot -> Just ot + Aeson.Error _ -> Nothing + +-- | Convert a list of Langchain 'Tool' definitions to Ollama 'OTool.Tool's +toOllamaTools :: [Tool m] -> [OTool.Tool] +toOllamaTools = mapMaybe toOllamaTool + +-- | Attach generic JSON format constraint to Ollama ChatRequest +withJsonFormat :: OllamaChat.ChatRequest -> OllamaChat.ChatRequest +withJsonFormat req = req {OllamaChat.chatFormat = Just OFormat.JsonFormat} + +-- | Attach specific Schema format constraint to Ollama ChatRequest +withSchemaFormat :: OSB.Schema -> OllamaChat.ChatRequest -> OllamaChat.ChatRequest +withSchemaFormat schema req = req {OllamaChat.chatFormat = Just (OFormat.SchemaFormat schema)} + +-- | Attach automatic ToSchema derived format constraint to Ollama ChatRequest +withStructuredOutput :: + forall a. + (OSD.ToSchema a) => + OllamaChat.ChatRequest -> + OllamaChat.ChatRequest +withStructuredOutput req = + req {OllamaChat.chatFormat = Just (OFormat.SchemaFormat (OSD.toSchema @a))} + +-- | Ollama model with pre-bound tools +data OllamaWithTools m = OllamaWithTools + { ollamaBaseModel :: !Ollama + , ollamaBoundTools :: ![Tool m] + } + +instance Show (OllamaWithTools m) where + show (OllamaWithTools m _) = "OllamaWithTools (" ++ show m ++ ")" + +-- | Bind tools to an Ollama model so any invocation automatically includes tool definitions +bindTools :: [Tool m] -> Ollama -> OllamaWithTools m +bindTools ts model = OllamaWithTools model ts + +instance ChatModel (OllamaWithTools m) where + type ModelConfig (OllamaWithTools m) = OllamaChat.ChatRequest + invoke (OllamaWithTools model ts) msgs mbReq = + let req = fromMaybe (chatRequestFor model msgs) mbReq + in invoke model msgs (Just (withTools ts req)) + stream (OllamaWithTools model ts) msgs mbReq = + let req = fromMaybe (chatRequestFor model msgs) mbReq + in stream model msgs (Just (withTools ts req)) + +-- | Bind tools to an Ollama model by creating/merging a ChatRequest with tool definitions +instance ToolBinder Ollama m where + bindToolsConfig tools mbReq = + case tools of + [] -> mbReq + _ -> + let baseReq = fromMaybe (OllamaChat.chatRequest (ModelName "") (O.userMessage "" NonEmpty.:| [])) mbReq + in Just $ withTools tools baseReq + +-- | OllamaWithTools already has tools bound, but merges additional tools if provided +instance ToolBinder (OllamaWithTools m) n where + bindToolsConfig tools mbReq = + case tools of + [] -> mbReq + _ -> + let baseReq = fromMaybe (OllamaChat.chatRequest (ModelName "") (O.userMessage "" NonEmpty.:| [])) mbReq + in Just $ withTools tools baseReq diff --git a/src/Langchain/Provider/OpenAI.hs b/src/Langchain/Provider/OpenAI.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Provider/OpenAI.hs @@ -0,0 +1,608 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{- | +Module : Langchain.Provider.OpenAI +Description : OpenAI provider implementing effect-polymorphic ChatModel +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +OpenAI and OpenAICompatible provider using the @openai@ Haskell package +for typed API calls. Multi-modal content and streaming support. +-} +module Langchain.Provider.OpenAI + ( OpenAI (..) + , OpenAIConfig (..) + , defaultConfig + , defaultOpenAIConfig + , OpenAIToolChoice (..) + , openAITools + , newOpenAI + , openAICompatible + , normalizeBaseUrl + , parseOpenAIResponse + ) where + +import Control.Applicative ((<|>)) +import Control.Concurrent.Async (AsyncCancelled (..)) +import Control.Exception (SomeException, fromException, throwIO, try) +import Control.Monad (forM) +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) +import qualified Data.Conduit.Combinators as C + +import Data.Aeson (Value (..), object, (.=)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as KeyMap +import Data.Aeson.Types (Parser, parseEither, parseMaybe) +import Data.Bifunctor (first) +import qualified Data.ByteString.Lazy as LBS +import Data.Conduit +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Vector as V +import GHC.Generics (Generic) + +import qualified OpenAI.V1 as OAI +import qualified OpenAI.V1.Chat.Completions as CC +import qualified OpenAI.V1.Models as OM +import qualified OpenAI.V1.ToolCall as OTC +import qualified OpenAI.V1.Usage as OU + +import Langchain.Core.Error (LangchainError, llmError) +import Langchain.Core.Model +import Langchain.Core.Stream (StreamEvent (..), StreamM, TokenUsage (..), callbackSource) +import Langchain.Core.Tool (Tool, toolToValue) +import Langchain.Tool.Binding (ToolBinder (..)) +import Network.HTTP.Client (newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Servant.API (Header, JSON, ReqBody, (:>)) +import Servant.API.EventStream + ( FromServerEvent (fromServerEvent) + , PostServerSentEvents + , ServerEvent (eventData) + , jsonData + ) +import Servant.Client.Core.BaseUrl (parseBaseUrl) +import Servant.Client.Streaming (ClientM, client, mkClientEnv, withClientM) +import Servant.Conduit () + +-- | Configuration for OpenAI provider +data OpenAIConfig = OpenAIConfig + { configApiKey :: Text + , configModel :: Text + , configBaseUrl :: Maybe Text + , configTemperature :: Maybe Double + } + deriving (Eq, Show, Generic, Aeson.ToJSON, Aeson.FromJSON) + +defaultConfig :: Text -> OpenAIConfig +defaultConfig key = OpenAIConfig key "gpt-4o" Nothing (Just 0.7) + +defaultOpenAIConfig :: Text -> OpenAIConfig +defaultOpenAIConfig = defaultConfig + +-- | OpenAI ChatModel implementation +data OpenAI = OpenAI + { apiKey :: Text + , model :: Text + , baseUrl :: Text + {- ^ Base URL (e.g. @"https://api.openai.com"@). The @openai@ package + automatically appends @\/v1\/chat\/completions@. + -} + , temperature :: Maybe Double + } + deriving (Eq, Show) + +-- | Controls how OpenAI chooses among request tool definitions. +data OpenAIToolChoice + = OpenAIToolAuto + | OpenAIToolNone + | OpenAIToolRequired + | OpenAIToolFunction Text + deriving (Eq, Show) + +-- | Build stream request options from langchain tools. +openAITools :: [Tool m] -> OpenAIToolChoice -> Value +openAITools tools choice = + object + [ "tools" .= map toolToValue tools + , "tool_choice" .= toolChoiceValue choice + ] + +toolChoiceValue :: OpenAIToolChoice -> Value +toolChoiceValue OpenAIToolAuto = String "auto" +toolChoiceValue OpenAIToolNone = String "none" +toolChoiceValue OpenAIToolRequired = String "required" +toolChoiceValue (OpenAIToolFunction name) = + object + [ "type" .= ("function" :: Text) + , "function" .= object ["name" .= name] + ] + +data OpenAIStreamEvent + = OpenAIChunk OpenAIStreamChunk + | OpenAIDone + +instance FromServerEvent OpenAIStreamEvent where + fromServerEvent event + | eventData event == "[DONE]" = Right OpenAIDone + | otherwise = OpenAIChunk <$> jsonData event + +data OpenAIStreamChunk = OpenAIStreamChunk + { streamChoices :: [OpenAIStreamChoice] + , streamUsage :: Maybe TokenUsage + } + +instance Aeson.FromJSON OpenAIStreamChunk where + parseJSON = Aeson.withObject "OpenAIStreamChunk" $ \obj -> + OpenAIStreamChunk + <$> obj Aeson..:? "choices" Aeson..!= [] + <*> (obj Aeson..:? "usage" >>= traverse parseOpenAIStreamUsage) + +parseOpenAIStreamUsage :: Value -> Parser TokenUsage +parseOpenAIStreamUsage = Aeson.withObject "OpenAIStreamUsage" $ \obj -> + TokenUsage + <$> obj Aeson..: "prompt_tokens" + <*> obj Aeson..: "completion_tokens" + <*> obj Aeson..: "total_tokens" + +data OpenAIStreamChoice = OpenAIStreamChoice + { streamChoiceIndex :: Int + , streamChoiceDelta :: OpenAIStreamDelta + } + +instance Aeson.FromJSON OpenAIStreamChoice where + parseJSON = Aeson.withObject "OpenAIStreamChoice" $ \obj -> + OpenAIStreamChoice + <$> obj Aeson..: "index" + <*> obj Aeson..: "delta" + +data OpenAIStreamDelta = OpenAIStreamDelta + { streamContent :: Maybe Text + , streamToolCalls :: [OpenAIStreamToolCall] + } + +instance Aeson.FromJSON OpenAIStreamDelta where + parseJSON = Aeson.withObject "OpenAIStreamDelta" $ \obj -> + OpenAIStreamDelta + <$> obj Aeson..:? "content" + <*> obj Aeson..:? "tool_calls" Aeson..!= [] + +data OpenAIStreamToolCall = OpenAIStreamToolCall + { streamToolCallIndex :: Int + , streamToolCallId :: Maybe Text + , streamToolCallName :: Maybe Text + , streamToolCallArguments :: Maybe Text + } + +instance Aeson.FromJSON OpenAIStreamToolCall where + parseJSON = Aeson.withObject "OpenAIStreamToolCall" $ \obj -> do + streamToolCallIndex <- obj Aeson..: "index" + streamToolCallId <- obj Aeson..:? "id" + streamFunction <- obj Aeson..:? "function" + let streamToolCallName = streamFunction >>= parseMaybe (Aeson..: "name") + streamToolCallArguments = streamFunction >>= parseMaybe (Aeson..: "arguments") + pure + OpenAIStreamToolCall + { streamToolCallIndex + , streamToolCallId + , streamToolCallName + , streamToolCallArguments + } + +data PartialToolCall = PartialToolCall + { partialToolCallId :: Maybe Text + , partialToolCallName :: Maybe Text + , partialToolCallArguments :: Text + } + +type OpenAIStreamApi = + "v1" + :> "chat" + :> "completions" + :> Header "Authorization" Text + :> ReqBody '[JSON] Value + :> PostServerSentEvents (ConduitT () OpenAIStreamEvent IO ()) + +openAIStreamClient :: + Maybe Text -> Value -> ClientM (ConduitT () OpenAIStreamEvent IO ()) +openAIStreamClient = client (Proxy :: Proxy OpenAIStreamApi) + +streamRequestBody :: CC.CreateChatCompletion -> Maybe Value -> Value +streamRequestBody request options = case Aeson.toJSON request of + Object fields -> + Object $ + KeyMap.insert "stream_options" (object ["include_usage" Aeson..= True]) $ + KeyMap.insert "stream" (Bool True) $ + KeyMap.union fields optionFields + value -> value + where + optionFields = case options of + Just (Object fields) -> fields + _ -> mempty + +-- | Create standard OpenAI provider instance +newOpenAI :: Text -> Text -> OpenAI +newOpenAI key mName = + OpenAI + { apiKey = key + , model = mName + , baseUrl = "https://api.openai.com" + , temperature = Just 0.7 + } + +{- | Create OpenAICompatible provider instance for OpenRouter/Fireworks/Together. + +The @endpoint@ should be the __base URL__ only (e.g. +@"https://openrouter.ai/api"@), not the full chat completions path. +The @openai@ package appends @\/v1\/chat\/completions@ automatically. +-} +openAICompatible :: Text -> Text -> Text -> OpenAI +openAICompatible key mName endpoint = + OpenAI + { apiKey = key + , model = mName + , baseUrl = endpoint + , temperature = Just 0.7 + } + +-- --------------------------------------------------------------------------- +-- Conversion: langchain-hs Message -> openai package Message +-- --------------------------------------------------------------------------- + +-- | Convert a langchain 'ContentBlock' to an openai 'CC.Content'. +contentBlockToOAI :: ContentBlock -> CC.Content +contentBlockToOAI (TextBlock t) = CC.Text {CC.text = t} +contentBlockToOAI (ImageBlock ImageContent {imageSource = ImageUrl url}) = + CC.Image_URL {CC.image_url = CC.ImageURL {CC.url = url, CC.detail = Nothing}} +contentBlockToOAI (ImageBlock ImageContent {imageSource = ImageBase64 (Just mime) b64}) = + CC.Image_URL + { CC.image_url = + CC.ImageURL + { CC.url = "data:" <> mime <> ";base64," <> b64 + , CC.detail = Nothing + } + } +contentBlockToOAI (ImageBlock ImageContent {imageSource = ImageBase64 Nothing b64}) = + CC.Image_URL + { CC.image_url = + CC.ImageURL + { CC.url = "data:application/octet-stream;base64," <> b64 + , CC.detail = Nothing + } + } +contentBlockToOAI (AudioBlock _mime _b64) = + -- Audio blocks are represented as text placeholders in the request + CC.Text {CC.text = "[Audio content]"} +contentBlockToOAI (DataBlock _) = + CC.Text {CC.text = "[Data block]"} + +-- | Convert a langchain 'Message' to an openai package 'CC.Message'. +toLangchainOAIMessage :: Message -> CC.Message (V.Vector CC.Content) +toLangchainOAIMessage msg = + let contents = V.fromList $ map contentBlockToOAI (NonEmpty.toList (messageContents msg)) + in case messageRole msg of + System -> + CC.System {CC.content = contents, CC.name = messageName msg} + User -> + CC.User {CC.content = contents, CC.name = messageName msg} + Assistant -> + CC.Assistant + { CC.assistant_content = Just contents + , CC.refusal = Nothing + , CC.name = messageName msg + , CC.assistant_audio = Nothing + , CC.tool_calls = V.fromList . map toOAIToolCall <$> messageToolCalls msg + } + Tool -> + CC.Tool + { CC.content = contents + , CC.tool_call_id = fromMaybe "" (messageToolId msg) + } + -- Developer and Function map to System for the openai package + Developer -> + CC.System {CC.content = contents, CC.name = messageName msg} + Function -> + CC.System {CC.content = contents, CC.name = messageName msg} + where + toOAIToolCall toolCall = + OTC.ToolCall_Function + { OTC.id = toolCallId toolCall + , OTC.function = OTC.Function {OTC.name = toolCallName toolCall, OTC.arguments = arguments toolCall} + } + + arguments = TE.decodeUtf8 . LBS.toStrict . Aeson.encode . toolCallArguments + +-- --------------------------------------------------------------------------- +-- Conversion: openai package response -> langchain-hs Message +-- --------------------------------------------------------------------------- + +-- | Convert an openai package 'CC.Choice' response message to a langchain 'Message'. +fromOAIMessage :: CC.Message Text -> Message +fromOAIMessage oaiMsg = case oaiMsg of + CC.Assistant {CC.assistant_content, CC.tool_calls = oaiToolCalls, CC.name = nm} -> + let contentText = fromMaybe "" assistant_content + baseMsg = (assistantMessage contentText) {messageName = nm} + tcList = case oaiToolCalls of + Nothing -> Nothing + Just tcs -> + Just $ + map + ( \(OTC.ToolCall_Function {OTC.id = tcId, OTC.function = fn}) -> + let argVal = case Aeson.decode (LBS.fromStrict (TE.encodeUtf8 (OTC.arguments fn))) of + Just v -> v + Nothing -> object [] + in ToolCall tcId "function" (OTC.name fn) argVal + ) + (V.toList tcs) + in baseMsg {messageToolCalls = tcList} + CC.System {CC.content = c} -> systemMessage c + CC.User {CC.content = c} -> userMessage c + CC.Tool {CC.content = c} -> + textMessage Tool c + +-- | Convert openai 'OU.Usage' to langchain 'TokenUsage'. +fromOAIUsage :: OU.Usage ctd ptd -> TokenUsage +fromOAIUsage u = + TokenUsage + { promptTokens = fromIntegral (OU.prompt_tokens u) + , completionTokens = fromIntegral (OU.completion_tokens u) + , totalTokens = fromIntegral (OU.total_tokens u) + } + +-- --------------------------------------------------------------------------- +-- ChatModel instance +-- --------------------------------------------------------------------------- + +instance ChatModel OpenAI where + type ModelConfig OpenAI = Value + + invoke provider inputMsgs mbOptions = do + resp <- liftIO $ first asText <$> try createComplention + case resp of + Left err -> throwError $ llmError' err + Right (CC.ChatCompletionObject {CC.choices = choicesVec, CC.usage = oaiUsage}) -> do + case V.toList choicesVec of + [] -> throwError $ llmError "Empty choices array in OpenAI response" Nothing Nothing + (choice : _) -> do + let respMsg = fromOAIMessage $ CC.message choice + _usage = fromOAIUsage oaiUsage + pure respMsg {messageToolCalls = messageToolCalls respMsg} + where + createComplention = do + methods <- getMethods + let baseBody = reqBody provider inputMsgs + body = mergeOptions baseBody mbOptions + OAI.createChatCompletion methods body + getMethods = do + clientEnv <- OAI.getClientEnv (normalizeBaseUrl (baseUrl provider)) + pure $ OAI.makeMethods clientEnv (apiKey provider) Nothing Nothing + + stream provider inputMsgs options = do + yield $ LLMStart rId (model provider) inputMsgs + + (accumulated, toolCalls, usage) <- + callbackSource openAIEvents + .| receiveChunks "" Map.empty Nothing + + yield $ LLMEnd rId ((assistantMessage accumulated) {messageToolCalls = toolCalls}) usage + where + rId = "openai-stream-run" + receiveChunks accumulated toolCalls usage = + await >>= \case + Nothing -> finishStream + Just (Left err) -> throwError $ llmError' err + Just (Right OpenAIDone) -> finishStream + Just (Right (OpenAIChunk OpenAIStreamChunk {streamChoices, streamUsage})) -> do + let (texts, nextToolCalls) = handleChoice $ choice0 streamChoices + nextUsage = streamUsage <|> usage + mapM_ (\text -> yield $ LLMChunk rId text Nothing) texts + receiveChunks (accumulated <> mconcat texts) nextToolCalls nextUsage + where + choice0 = List.find $ (== 0) . streamChoiceIndex + + handleChoice Nothing = ([], toolCalls) + handleChoice (Just OpenAIStreamChoice {streamChoiceDelta = OpenAIStreamDelta {streamContent, streamToolCalls}}) = + let nextToolCalls = List.foldl' addToolCall toolCalls streamToolCalls + in (maybe [] pure streamContent, nextToolCalls) + + addToolCall + toolCalls' + OpenAIStreamToolCall + { streamToolCallIndex + , streamToolCallId + , streamToolCallName + , streamToolCallArguments + } = + Map.alter (Just . update) streamToolCallIndex toolCalls' + where + update curr = + let prevId = curr >>= partialToolCallId + prevName = curr >>= partialToolCallName + prevArgs = maybe "" partialToolCallArguments curr + nextArgs = fromMaybe "" streamToolCallArguments + in PartialToolCall + { partialToolCallId = streamToolCallId <|> prevId + , partialToolCallName = streamToolCallName <|> prevName + , partialToolCallArguments = prevArgs <> nextArgs + } + + finishStream = do + let finalizeToolCalls = traverse toToolCall $ Map.elems toolCalls + finalToolCalls <- lift finalizeToolCalls + mapM_ (yield . LLMChunk rId "" . Just) finalToolCalls + pure (accumulated, nonEmpty finalToolCalls, usage) + where + nonEmpty [] = Nothing + nonEmpty xs = Just xs + + toToolCall :: PartialToolCall -> StreamM ToolCall + toToolCall PartialToolCall {partialToolCallId, partialToolCallName, partialToolCallArguments} = do + toolCallId <- + fromMaybeOrThrow "OpenAI stream ended with a tool call missing an id" partialToolCallId + toolCallName <- + fromMaybeOrThrow "OpenAI stream ended with a tool call missing a function name" partialToolCallName + toolCallArguments <- + either + (throwLlmError . ("Invalid JSON arguments in OpenAI tool call: " <>) . T.pack) + pure + (decode partialToolCallArguments) + pure ToolCall {toolCallId, toolCallType = "function", toolCallName, toolCallArguments} + + throwLlmError = throwError . llmError' + fromMaybeOrThrow err = maybe (throwLlmError err) pure + decode = Aeson.eitherDecode . LBS.fromStrict . TE.encodeUtf8 + + -- \| Internal function to handle streaming events from OpenAI. + openAIEvents emit = do + result <- try $ do + manager <- newManager tlsManagerSettings + let baseUrl' = T.unpack $ normalizeBaseUrl $ baseUrl provider + clientEnv <- mkClientEnv manager <$> parseBaseUrl baseUrl' + let body = reqBody provider inputMsgs + bearerToken = Just $ "Bearer " <> apiKey provider + request = openAIStreamClient bearerToken $ streamRequestBody body options + + withClientM request clientEnv $ \case + Left err -> + emit $ Left $ T.pack $ show err + Right source -> + runConduit $ + source .| C.mapM_ (emit . Right) + + case result of + Left err + | Just AsyncCancelled <- fromException err -> throwIO err + | otherwise -> emit $ Left $ asText err + Right () -> pure () + +-- | Convert a 'SomeException' to 'Text' for error reporting. +asText :: SomeException -> Text +asText ex = T.pack $ show (ex :: SomeException) + +-- | Construct a 'LangchainError' for LLM errors with optional details. +llmError' :: Text -> LangchainError +llmError' msg = llmError msg Nothing Nothing + +-- | Merge option fields (tools, tool_choice, response_format, etc.) into a 'CreateChatCompletion'. +mergeOptions :: CC.CreateChatCompletion -> Maybe Value -> CC.CreateChatCompletion +mergeOptions body Nothing = body +mergeOptions body (Just opts) = + case Aeson.toJSON body of + Object baseFields -> + let optFields = case opts of + Object fs -> fs + _ -> mempty + merged = KeyMap.union optFields baseFields + in case Aeson.fromJSON (Object merged) of + Aeson.Success merged' -> merged' + _ -> body -- fallback: ignore unparseable options + _ -> body + +-- | Construct the request body for OpenAI chat completion. +reqBody :: OpenAI -> [Message] -> CC.CreateChatCompletion +reqBody provider inputMsgs = + CC._CreateChatCompletion + { CC.messages = toVec inputMsgs + , CC.model = OM.Model $ model provider + , CC.temperature = temperature provider + } + where + toVec = V.fromList . map toLangchainOAIMessage + +{- | Normalize base URL to ensure compatibility with the @openai@ package. +Strips any trailing @/v1/chat/completions@, @/chat/completions@, or @/v1@ +so that Servant's route constructs the expected URL path. +-} +normalizeBaseUrl :: Text -> Text +normalizeBaseUrl rawUrl = + let u0 = T.dropWhileEnd (== '/') rawUrl + u1 + | "/v1/chat/completions" `T.isSuffixOf` u0 = + T.dropEnd (T.length "/v1/chat/completions") u0 + | "/chat/completions" `T.isSuffixOf` u0 = + T.dropEnd (T.length "/chat/completions") u0 + | "/v1" `T.isSuffixOf` u0 = + T.dropEnd (T.length "/v1") u0 + | otherwise = + u0 + in T.dropWhileEnd (== '/') u1 + +-- --------------------------------------------------------------------------- +-- Backward-compatible parseOpenAIResponse +-- --------------------------------------------------------------------------- + +{- | Parse a raw OpenAI JSON response 'Value' into a langchain 'Message' +and optional 'TokenUsage'. + +This function is provided for backward compatibility. New code should use +the typed @openai@ package types directly. +-} +parseOpenAIResponse :: Value -> Either String (Message, Maybe TokenUsage) +parseOpenAIResponse = parseEither $ Aeson.withObject "OpenAIResponse" $ \o -> do + choices <- o Aeson..: "choices" + usageVal <- o Aeson..:? "usage" + mbUsage <- case usageVal of + Nothing -> pure Nothing + Just u -> flip (Aeson.withObject "Usage") u $ \uo -> do + pTok <- uo Aeson..:? "prompt_tokens" Aeson..!= 0 + cTok <- uo Aeson..:? "completion_tokens" Aeson..!= 0 + tTok <- uo Aeson..:? "total_tokens" Aeson..!= 0 + pure $ Just $ TokenUsage pTok cTok tTok + case choices of + [] -> fail "Empty choices array in OpenAI response" + (c : _) -> flip (Aeson.withObject "Choice") c $ \ch -> do + msgObj <- ch Aeson..: "message" + contentTxt <- msgObj Aeson..:? "content" Aeson..!= "" + mbToolCalls <- msgObj Aeson..:? "tool_calls" + cToolCalls <- case mbToolCalls of + Nothing -> pure Nothing + Just tcs -> do + calls <- forM (tcs :: [Value]) $ Aeson.withObject "ToolCall" $ \tcObj -> do + tcId <- tcObj Aeson..:? "id" Aeson..!= "" + fnObj <- tcObj Aeson..: "function" + fnName <- fnObj Aeson..: "name" + fnArgsVal <- fnObj Aeson..:? "arguments" + let fnArgs = case fnArgsVal of + Just (String s) -> case Aeson.decode (LBS.fromStrict (TE.encodeUtf8 s)) of + Just val -> val + Nothing -> object [] + Just obj@(Object _) -> obj + _ -> object [] + pure $ ToolCall tcId "function" fnName fnArgs + pure (Just calls) + let msg = (assistantMessage contentTxt) {messageToolCalls = cToolCalls} + pure (msg, mbUsage) + +-- | Bind tools to an OpenAI model by merging tool definitions into the options Value +instance ToolBinder OpenAI m where + bindToolsConfig tools mbOpts = + case tools of + [] -> mbOpts + _ -> + let toolsVal = openAITools tools OpenAIToolAuto + in Just $ case (mbOpts, toolsVal) of + (Nothing, v) -> v + (Just (Object existing), Object newFields) -> + Object (KeyMap.union newFields existing) + (Just existing, _) -> existing diff --git a/src/Langchain/Resilience/CircuitBreaker.hs b/src/Langchain/Resilience/CircuitBreaker.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Resilience/CircuitBreaker.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.Resilience.CircuitBreaker +Description : Circuit breaker pattern for LLM provider failover and graceful degradation +Copyright : (c) 2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Implements the Circuit Breaker pattern (Closed, Open, HalfOpen) to prevent cascading failures +when upstream LLM APIs or vector stores experience outages. +-} +module Langchain.Resilience.CircuitBreaker + ( CircuitState (..) + , CircuitBreakerConfig (..) + , defaultCircuitConfig + , CircuitBreaker (..) + , newCircuitBreaker + , getCircuitState + , withCircuitBreaker + ) where + +import Control.Concurrent.STM +import Control.Monad.Except (MonadError, catchError, throwError) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) +import GHC.Generics (Generic) + +import Langchain.Core.Error (LangchainError, internalError) + +-- | State of the circuit breaker +data CircuitState + = CircuitClosed + | CircuitOpen !UTCTime -- Timestamp when opened + | CircuitHalfOpen + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | Configuration parameters for the circuit breaker +data CircuitBreakerConfig = CircuitBreakerConfig + { failureThreshold :: !Int + , resetTimeoutSec :: !Double + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | Sensible default configuration (5 failures to open, 30 seconds reset timeout) +defaultCircuitConfig :: CircuitBreakerConfig +defaultCircuitConfig = + CircuitBreakerConfig + { failureThreshold = 5 + , resetTimeoutSec = 30.0 + } + +-- | Circuit breaker handle backed by STM TVar +data CircuitBreaker = CircuitBreaker + { circuitName :: !Text + , circuitConfig :: !CircuitBreakerConfig + , circuitStateVar :: !(TVar (CircuitState, Int)) -- (State, consecutive failures) + } + +-- | Construct a new CircuitBreaker +newCircuitBreaker :: MonadIO m => Text -> CircuitBreakerConfig -> m CircuitBreaker +newCircuitBreaker name cfg = liftIO $ do + var <- newTVarIO (CircuitClosed, 0) + pure $ CircuitBreaker name cfg var + +-- | Query current state of the circuit breaker +getCircuitState :: MonadIO m => CircuitBreaker -> m CircuitState +getCircuitState CircuitBreaker {..} = liftIO $ do + (st, _) <- readTVarIO circuitStateVar + pure st + +-- | Execute a protected action through the circuit breaker +withCircuitBreaker :: + (MonadIO m, MonadError LangchainError m) => + CircuitBreaker -> + m a -> + m a +withCircuitBreaker CircuitBreaker {..} action = do + now <- liftIO getCurrentTime + canProceed <- liftIO $ atomically $ do + (st, _) <- readTVar circuitStateVar -- Only the state is needed to gate; count is managed in the error handler below + case st of + CircuitClosed -> pure True + CircuitHalfOpen -> pure True + CircuitOpen openTime -> + if diffUTCTime now openTime >= realToFrac (resetTimeoutSec circuitConfig) + then do + writeTVar circuitStateVar (CircuitHalfOpen, 0) + pure True + else pure False + + if not canProceed + then + throwError $ + internalError + ("Circuit breaker '" <> circuitName <> "' is OPEN. Fast-failing request.") + (Just circuitName) + Nothing + else do + res <- + action `catchError` \err -> do + liftIO $ atomically $ do + (st, fails) <- readTVar circuitStateVar + let newFails = fails + 1 + if newFails >= failureThreshold circuitConfig + then writeTVar circuitStateVar (CircuitOpen now, newFails) + else writeTVar circuitStateVar (st, newFails) + throwError err + + -- On success, reset circuit to closed and reset failure count + liftIO $ atomically $ writeTVar circuitStateVar (CircuitClosed, 0) + pure res diff --git a/src/Langchain/Resilience/Retry.hs b/src/Langchain/Resilience/Retry.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Resilience/Retry.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.Resilience.Retry +Description : Retry policies with exponential backoff and token-bucket rate limiting +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Resilience combinators for network calls and LLM provider invocations. +-} +module Langchain.Resilience.Retry + ( RetryPolicy (..) + , defaultRetryPolicy + , withRetry + , RateLimiter (..) + , newRateLimiter + , withRateLimit + ) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.STM +import Control.Monad (when) +import Control.Monad.Except (MonadError, catchError, throwError) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Time.Clock +import System.Random (randomRIO) + +import Langchain.Core.Error (LangchainError) + +-- | Exponential backoff retry policy +data RetryPolicy = RetryPolicy + { maxRetries :: !Int + , baseDelayMicros :: !Int + , maxDelayMicros :: !Int + , useJitter :: !Bool + } + deriving (Show, Eq) + +-- | Default retry policy (3 retries, base 50ms, max 2s, with jitter) +defaultRetryPolicy :: RetryPolicy +defaultRetryPolicy = + RetryPolicy + { maxRetries = 3 + , baseDelayMicros = 50000 + , maxDelayMicros = 2000000 + , useJitter = True + } + +-- | Execute an action with retry according to RetryPolicy on LangchainError +withRetry :: + (MonadIO m, MonadError LangchainError m) => + RetryPolicy -> + m a -> + m a +withRetry policy action = go (maxRetries policy) (baseDelayMicros policy) + where + go retriesLeft currentDelay = + action `catchError` \err -> + if retriesLeft <= 0 + then throwError err + else do + delayWithJitter <- + if useJitter policy + then liftIO $ randomRIO (currentDelay `div` 2, currentDelay) + else pure currentDelay + liftIO $ threadDelay delayWithJitter + let nextDelay = min (maxDelayMicros policy) (currentDelay * 2) + go (retriesLeft - 1) nextDelay + +-- | Token bucket rate limiter backed by STM TVars +data RateLimiter = RateLimiter + { bucketCapacity :: !Double + , refillRatePerSec :: !Double + , tokensVar :: !(TVar Double) + , lastRefillVar :: !(TVar UTCTime) + } + +-- | Construct a new Token Bucket RateLimiter (e.g. capacity = 10 tokens, refill = 5 tokens/sec) +newRateLimiter :: MonadIO m => Double -> Double -> m RateLimiter +newRateLimiter cap rate = liftIO $ do + now <- getCurrentTime + tVar <- newTVarIO cap + rVar <- newTVarIO now + pure $ RateLimiter cap rate tVar rVar + +-- | Execute an action subject to token-bucket rate limiting (blocks if bucket empty) +withRateLimit :: (MonadIO m) => RateLimiter -> m a -> m a +withRateLimit RateLimiter {..} action = do + liftIO $ do + waitForToken + action + where + waitForToken = do + now <- getCurrentTime + waitNeeded <- atomically $ do + lastTime <- readTVar lastRefillVar + tokens <- readTVar tokensVar + let elapsedSecs = realToFrac (diffUTCTime now lastTime) :: Double + refilledTokens = min bucketCapacity (tokens + elapsedSecs * refillRatePerSec) + if refilledTokens >= 1.0 + then do + writeTVar tokensVar (refilledTokens - 1.0) + writeTVar lastRefillVar now + pure (0 :: Int) + else do + let deficit = 1.0 - refilledTokens + sleepSecs = deficit / refillRatePerSec + pure (ceiling (sleepSecs * 1000000) :: Int) + when (waitNeeded > 0) $ do + threadDelay waitNeeded + waitForToken diff --git a/src/Langchain/Retriever/BM25.hs b/src/Langchain/Retriever/BM25.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Retriever/BM25.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module : Langchain.Retriever.BM25 +Description : Okapi BM25 Sparse Inverted Index Retriever +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Pure Haskell implementation of the Okapi BM25 ranking algorithm for sparse keyword retrieval. +Supports document addition, customized k1 and b parameters, and fast inverted index scoring. +-} +module Langchain.Retriever.BM25 + ( BM25Index (..) + , newBM25Index + , newBM25IndexWithParams + , addDocumentsBM25 + , bm25Search + , bm25SearchWithScores + , tokenize + ) where + +import Langchain.Core.Runnable (Runnable (..)) + +import Data.Char (isAlphaNum) +#if MIN_VERSION_base(4,20,0) +import Data.List (sortBy) +#else +import Data.List (foldl', sortBy) +#endif +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Ord (Down (..), comparing) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import GHC.Generics (Generic) + +import Langchain.DocumentLoader.Core (Document (..)) +import Langchain.Retriever.Core (Retriever (..)) + +-- | BM25 Index containing documents, lengths, and inverted index +data BM25Index = BM25Index + { bm25Docs :: ![Document] + , bm25DocLens :: !(Map Int Int) + , bm25AvgDocLen :: !Double + , bm25InvertedIndex :: !(Map Text (Map Int Int)) + , bm25K1 :: !Double + , bm25B :: !Double + } + deriving (Show, Eq, Generic) + +instance Retriever BM25Index where + getRelevantDocuments index query = pure $ bm25Search index query 5 + +-- | Tokenize text into lowercased alphanumeric terms +tokenize :: Text -> [Text] +tokenize = filter (not . T.null) . map (T.filter isAlphaNum . T.toLower) . T.words + +-- | Construct a BM25 index with default parameters (k1 = 1.5, b = 0.75) +newBM25Index :: [Document] -> BM25Index +newBM25Index = newBM25IndexWithParams 1.5 0.75 + +-- | Construct a BM25 index with customized k1 and b parameters +newBM25IndexWithParams :: Double -> Double -> [Document] -> BM25Index +newBM25IndexWithParams k1 b docs = + let indexedDocs = zip [0 ..] docs + docLensList = [(i, length (tokenize (TL.toStrict (pageContent d)))) | (i, d) <- indexedDocs] + docLens = Map.fromList docLensList + totalTokens = sum (map snd docLensList) + nDocs = length docs + avgLen = if nDocs > 0 then fromIntegral totalTokens / fromIntegral nDocs else 0.0 + + -- Build inverted index: term -> docIndex -> termFrequency + invIndex = foldl' addDocToInvertedIndex Map.empty indexedDocs + in BM25Index + { bm25Docs = docs + , bm25DocLens = docLens + , bm25AvgDocLen = avgLen + , bm25InvertedIndex = invIndex + , bm25K1 = k1 + , bm25B = b + } + where + addDocToInvertedIndex acc (docIdx, doc) = + let tokens = tokenize (TL.toStrict (pageContent doc)) + tfs = foldl' (\m t -> Map.insertWith (+) t 1 m) Map.empty tokens + in Map.foldlWithKey' + (\accM t count -> Map.insertWith Map.union t (Map.singleton docIdx count) accM) + acc + tfs + +-- | Add new documents to an existing BM25 index +addDocumentsBM25 :: [Document] -> BM25Index -> BM25Index +addDocumentsBM25 newDocs BM25Index {..} = + newBM25IndexWithParams bm25K1 bm25B (bm25Docs ++ newDocs) + +-- | Perform BM25 search returning top-k documents sorted by score +bm25Search :: BM25Index -> Text -> Int -> [Document] +bm25Search index query k = map fst (bm25SearchWithScores index query k) + +-- | Perform BM25 search returning top-k documents with their relevance scores +bm25SearchWithScores :: BM25Index -> Text -> Int -> [(Document, Double)] +bm25SearchWithScores BM25Index {..} query k + | null bm25Docs || null queryTokens = [] + | otherwise = + let nTotalDocs = fromIntegral (length bm25Docs) + -- Accumulate BM25 score per document + scores = foldl' (scoreTerm nTotalDocs) (Map.empty :: Map Int Double) queryTokens + indexedDocs = zip [0 ..] bm25Docs + scoredList = + [ (doc, score) + | (idx, doc) <- indexedDocs + , let score = Map.findWithDefault 0.0 idx scores + , score > 0.0 + ] + sorted = sortBy (comparing (Down . snd)) scoredList + in take k sorted + where + queryTokens = tokenize query + + scoreTerm nTotalDocs accScores term = + case Map.lookup term bm25InvertedIndex of + Nothing -> accScores + Just postingMap -> + let nDocWithTerm = fromIntegral (Map.size postingMap) + -- Okapi BM25 IDF: ln(1 + (N - n + 0.5) / (n + 0.5)) + idf = log (1.0 + (nTotalDocs - nDocWithTerm + 0.5) / (nDocWithTerm + 0.5)) + in Map.foldlWithKey' (updateDocScore idf) accScores postingMap + + updateDocScore idf acc docIdx tf = + let docLen = fromIntegral (Map.findWithDefault 1 docIdx bm25DocLens) + normLen = if bm25AvgDocLen > 0 then docLen / bm25AvgDocLen else 1.0 + tfD = fromIntegral tf + -- Okapi BM25 TF component + tfWeight = (tfD * (bm25K1 + 1.0)) / (tfD + bm25K1 * (1.0 - bm25B + bm25B * normLen)) + scoreDelta = idf * tfWeight + in Map.insertWith (+) docIdx scoreDelta acc + +-- | 'BM25Index' implements 'Runnable' mapping a search query 'Text' to '[Document]' results. +instance Monad m => Runnable BM25Index m where + type RunnableInput BM25Index = Text + type RunnableOutput BM25Index = [Document] + invoke idx query = pure $ Right (bm25Search idx query 5) diff --git a/src/Langchain/Retriever/Core.hs b/src/Langchain/Retriever/Core.hs --- a/src/Langchain/Retriever/Core.hs +++ b/src/Langchain/Retriever/Core.hs @@ -1,132 +1,66 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} {- | Module : Langchain.Retriever.Core Description : Retrieval mechanism implementation for LangChain Haskell -Copyright : (c) 2025 Tushar Adhatrao +Copyright : (c) 2025-2026 Tushar Adhatrao License : MIT Maintainer : Tushar Adhatrao Stability : experimental -Haskell implementation of LangChain's retrieval abstraction, providing: - -- Document retrieval based on semantic similarity -- Integration with vector stores -- Runnable interface for workflow composition - -Example usage: - -@ --- Hypothetical vector store instance -vectorStore :: MyVectorStore -vectorStore = ... - --- Create retriever -retriever :: VectorStoreRetriever MyVectorStore -retriever = VectorStoreRetriever vectorStore - --- Retrieve relevant documents -docs <- invoke retriever "Haskell programming" --- Right [Document {pageContent = "...", ...}, ...] -@ +Effect-polymorphic document retrieval abstraction. -} module Langchain.Retriever.Core ( Retriever (..) , VectorStoreRetriever (..) + , retrieveWithCallbacks + , runRetriever ) where +import Control.Monad.Except (MonadError, runExceptT) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Text (Text) -import Langchain.DocumentLoader.Core (Document) -import Langchain.Error (LangchainResult) -import Langchain.Runnable.Core -import Langchain.VectorStore.Core - -{- | Typeclass for document retrieval systems -Implementations should return documents relevant to a given query. - -Example instance for a custom retriever: +import qualified Data.Text.Lazy as TL +import Data.Time.Clock (diffUTCTime, getCurrentTime) -@ -data CustomRetriever = CustomRetriever +import Langchain.Callback.Manager (CallbackEvent (..), CallbackManager, dispatchEvent) +import Langchain.Core.Error (LangchainError) +import Langchain.Core.Runnable (RunnableTree, runLambda) +import Langchain.DocumentLoader.Core (Document (..)) +import Langchain.VectorStore.Core (VectorStore, similaritySearch) -instance Retriever CustomRetriever where - _get_relevant_documents _ query = do - -- Custom retrieval logic - return $ Right [Document ("Result for: " <> query) mempty] -@ --} +-- | Effect-polymorphic Retriever typeclass class Retriever a where - {- | Retrieve documents relevant to the query - - Example: - - >>> _get_relevant_documents (VectorStoreRetriever myStore) "AI" - Right [Document "AI definition...", ...] - -} - _get_relevant_documents :: a -> Text -> IO (LangchainResult [Document]) - - _get_relevant_documentsM :: MonadIO m => a -> Text -> m (LangchainResult [Document]) - _get_relevant_documentsM retriever query = liftIO $ _get_relevant_documents retriever query - -{- | Vector store-backed retriever implementation -Wraps any 'VectorStore' instance to provide similarity-based retrieval. - -Example usage: - -@ --- Using a hypothetical FAISS vector store -faissStore :: FAISSStore -faissStore = ... - --- Create vector store retriever -vsRetriever = VectorStoreRetriever faissStore + getRelevantDocuments :: + (MonadIO m, MonadError LangchainError m) => + a -> + Text -> + m [Document] --- Get similar documents -docs <- _get_relevant_documents vsRetriever "machine learning" --- Returns top 5 relevant documents by default -@ --} +-- | Vector store-backed retriever newtype VectorStore a => VectorStoreRetriever a = VectorStoreRetriever {vs :: a} deriving (Eq, Show) -{- | Runnable interface for vector store retrievers -Allows integration with LangChain workflows and expressions. - -Example: - ->>> invoke (VectorStoreRetriever store) "Quantum computing" -Right [Document "Quantum theory...", ...] --} instance VectorStore a => Retriever (VectorStoreRetriever a) where - _get_relevant_documents (VectorStoreRetriever v) query = similaritySearch v query 5 - -{- | Runnable interface for vector store retrievers -Allows integration with LangChain workflows and expressions. - -Example: - ->>> invoke (VectorStoreRetriever store) "Quantum computing" -Right [Document "Quantum theory...", ...] --} -instance VectorStore a => Runnable (VectorStoreRetriever a) where - type RunnableInput (VectorStoreRetriever a) = Text - type RunnableOutput (VectorStoreRetriever a) = [Document] - - invoke = _get_relevant_documents - -{- $examples -Test case patterns: -1. Basic retrieval - >>> let retriever = VectorStoreRetriever mockStore - >>> _get_relevant_documents retriever "Test" - Right [Document "Test content" ...] + getRelevantDocuments (VectorStoreRetriever v) query = similaritySearch v query 5 -2. Runnable integration - >>> run retriever "Hello" - Right [Document "Greeting response" ...] +-- | Retrieve documents with lifecycle callbacks dispatched to CallbackManager +retrieveWithCallbacks :: + (Retriever a, MonadIO m, MonadError LangchainError m) => + CallbackManager -> + Text -> + a -> + Text -> + m [Document] +retrieveWithCallbacks mgr name ret query = do + start <- liftIO getCurrentTime + dispatchEvent mgr (OnRetrieverStart name query start) + docs <- getRelevantDocuments ret query + end <- liftIO getCurrentTime + let durMicros = round (diffUTCTime end start * 1000000) + dispatchEvent mgr (OnRetrieverEnd name (map (TL.toStrict . pageContent) docs) durMicros end) + pure docs -3. Error handling - >>> _get_relevant_documents (VectorStoreRetriever invalidStore) "Query" - Left "Vector store error" --} +-- | Lift any 'Retriever' into a 'Text' -> '[Document]' pipeline step in a 'RunnableTree'. +runRetriever :: (Retriever a, MonadIO m) => a -> RunnableTree m Text [Document] +runRetriever ret = runLambda $ \query -> runExceptT (getRelevantDocuments ret query) diff --git a/src/Langchain/Retriever/Hybrid.hs b/src/Langchain/Retriever/Hybrid.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Retriever/Hybrid.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module : Langchain.Retriever.Hybrid +Description : Hybrid Dense + Sparse Retriever with Reciprocal Rank Fusion (RRF) +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Combines sparse keyword search (BM25) and dense semantic vector search using +Reciprocal Rank Fusion (RRF) scoring: RRF(d) = sum_i ( weight_i / (k + rank_i(d)) ). +-} +module Langchain.Retriever.Hybrid + ( HybridRetriever (..) + , newHybridRetriever + , newHybridRetrieverWithWeights + , searchHybrid + , searchHybridWithScores + , reciprocalRankFusion + ) where + +import Control.Monad.Except (runExceptT) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Langchain.Core.Runnable (Runnable (..)) +#if MIN_VERSION_base(4,20,0) +import Data.List (sortBy) +#else +import Data.List (foldl', sortBy) +#endif +import qualified Data.Map.Strict as Map +import Data.Ord (Down (..), comparing) +import Data.Text (Text) + +import Langchain.DocumentLoader.Core (Document (..)) +import Langchain.Retriever.BM25 (BM25Index, bm25Search) +import Langchain.Retriever.Core (Retriever (..)) + +-- | Configuration and handles for Hybrid Retrieval +data HybridRetriever = HybridRetriever + { hybridBM25 :: !BM25Index + , hybridVectorSearch :: !(Text -> Int -> IO [Document]) + , hybridRrfK :: !Double + , hybridDenseWeight :: !Double + , hybridSparseWeight :: !Double + } + +instance Show HybridRetriever where + show HybridRetriever {..} = + "HybridRetriever { hybridRrfK = " + ++ show hybridRrfK + ++ ", hybridDenseWeight = " + ++ show hybridDenseWeight + ++ ", hybridSparseWeight = " + ++ show hybridSparseWeight + ++ " }" + +instance Retriever HybridRetriever where + getRelevantDocuments hr query = searchHybrid hr query 5 + +-- | Construct a default Hybrid Retriever (rrfK = 60.0, equal weights = 1.0) +newHybridRetriever :: + BM25Index -> + (Text -> Int -> IO [Document]) -> + HybridRetriever +newHybridRetriever bm25 vecSearch = + newHybridRetrieverWithWeights bm25 vecSearch 60.0 1.0 1.0 + +-- | Construct a Hybrid Retriever with custom RRF smoothing and weights +newHybridRetrieverWithWeights :: + BM25Index -> + (Text -> Int -> IO [Document]) -> + Double -> + Double -> + Double -> + HybridRetriever +newHybridRetrieverWithWeights bm25 vecSearch rrfK denseW sparseW = + HybridRetriever + { hybridBM25 = bm25 + , hybridVectorSearch = vecSearch + , hybridRrfK = rrfK + , hybridDenseWeight = denseW + , hybridSparseWeight = sparseW + } + +-- | Compute Reciprocal Rank Fusion score for documents across ranked lists +reciprocalRankFusion :: + Double -> + [([Document], Double)] -> -- List of (ranked documents, weight) + [(Document, Double)] +reciprocalRankFusion rrfK rankedLists = + let scoreMap = foldl' processList Map.empty rankedLists + docLookup = foldl' buildLookup Map.empty [d | (docs, _) <- rankedLists, d <- docs] + scoredDocs = + [ (doc, score) + | (contentKey, score) <- Map.toList scoreMap + , Just doc <- [Map.lookup contentKey docLookup] + ] + in sortBy (comparing (Down . snd)) scoredDocs + where + processList accMap (docs, weight) = + let indexed = zip [1 ..] docs + in foldl' (updateScore weight) accMap indexed + + updateScore weight acc (rank, doc) = + let key = pageContent doc + delta = weight / (rrfK + rank) + in Map.insertWith (+) key delta acc + + buildLookup acc doc = Map.insert (pageContent doc) doc acc + +-- | Execute hybrid search returning top-k documents +searchHybrid :: + (MonadIO m) => + HybridRetriever -> + Text -> + Int -> + m [Document] +searchHybrid hr query k = map fst <$> searchHybridWithScores hr query k + +-- | Execute hybrid search returning top-k documents with RRF scores +searchHybridWithScores :: + (MonadIO m) => + HybridRetriever -> + Text -> + Int -> + m [(Document, Double)] +searchHybridWithScores HybridRetriever {..} query k = do + -- 1. Run sparse BM25 search (fetch 2 * k candidates) + let sparseDocs = bm25Search hybridBM25 query (k * 2) + + -- 2. Run dense vector search (fetch 2 * k candidates) + denseDocs <- liftIO $ hybridVectorSearch query (k * 2) + + -- 3. Fuse rankings via RRF + let fused = + reciprocalRankFusion + hybridRrfK + [ (denseDocs, hybridDenseWeight) + , (sparseDocs, hybridSparseWeight) + ] + + pure $ take k fused + +-- | 'HybridRetriever' implements 'Runnable' mapping search query 'Text' to fused '[Document]' results. +instance MonadIO m => Runnable HybridRetriever m where + type RunnableInput HybridRetriever = Text + type RunnableOutput HybridRetriever = [Document] + invoke hr query = runExceptT (searchHybrid hr query 5) diff --git a/src/Langchain/Retriever/MultiQueryRetriever.hs b/src/Langchain/Retriever/MultiQueryRetriever.hs deleted file mode 100644 --- a/src/Langchain/Retriever/MultiQueryRetriever.hs +++ /dev/null @@ -1,288 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - -{- | -Module : Langchain.Retriever.MultiQueryRetriever -Description : Multi-query retrieval implementation for LangChain Haskell -Copyright : (c) 2025 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental - -Advanced retriever implementation that generates multiple queries from a single -input to improve document retrieval. Integrates with LLMs for query expansion -and vector stores for document retrieval - -Example usage: - -@ --- Create components -ollamaLLM = Ollama "llama3" [] -vs = VectorStoreRetriever (createVectorStore ...) - --- Create retriever with default config -mqRetriever = newMultiQueryRetriever vs ollamaLLM - --- Retrieve documents -docs <- _get_relevant_documents mqRetriever "Haskell features" --- Returns combined results from multiple generated queries -@ --} -module Langchain.Retriever.MultiQueryRetriever - ( MultiQueryRetriever (..) - , QueryGenerationPrompt (..) - , newMultiQueryRetriever - , defaultQueryGenerationPrompt - , newMultiQueryRetrieverWithConfig - , defaultMultiQueryRetrieverConfig - , generateQueries - ) where - -import Langchain.DocumentLoader.Core (Document) -import Langchain.LLM.Core (LLM (..)) -import Langchain.OutputParser.Core (NumberSeparatedList (..), OutputParser (..)) -import Langchain.PromptTemplate (PromptTemplate (..), renderPrompt) -import Langchain.Retriever.Core (Retriever (..)) -import qualified Langchain.Runnable.Core as Run - -import Data.Either (rights) -import Data.List (nub) -import qualified Data.Map.Strict as HM -import Data.Text (Text) -import qualified Data.Text as T -import Langchain.Error (LangchainError, llmError) - -{- | Query generation prompt template -Controls how the LLM generates multiple query variants from the original query. - -Example prompt structure: - -@ -"You are an AI assistant... Original query: {query}... Generate {num_queries} versions..." -@ --} -newtype QueryGenerationPrompt = QueryGenerationPrompt PromptTemplate - deriving (Show, Eq) - -{- | Default query generation prompt -Generates 3 query variants in numbered list format. Includes instructions for -query diversity and formatting. --} -defaultQueryGenerationPrompt :: QueryGenerationPrompt -defaultQueryGenerationPrompt = - QueryGenerationPrompt $ - PromptTemplate - { templateString = - T.unlines - [ "You are an AI language model assistant that helps users by generating multiple search queries based on their initial query." - , "These queries should help retrieve relevant documents or information from a vector database." - , "" - , "Original query: {query}" - , "" - , "Please generate {num_queries} different versions of this query that will help the user find the most relevant information." - , "The queries should be different but related to the original query." - , "Return these queries in the following format: 1. query 1 \n 2. query 2 \n 3. query 3" - , "Only return queries and nothing else" - ] - } - --- | Configuration for multi-query retrieval -data MultiQueryRetrieverConfig = MultiQueryRetrieverConfig - { numQueries :: Int - -- ^ Number of queries to generate - , queryGenerationPrompt :: QueryGenerationPrompt - -- ^ Prompt template for query generation - , includeMergeDocs :: Bool - -- ^ Whether to include merged documents - , includeOriginalQuery :: Bool - -- ^ Whether to include results from original query - } - -{- | Default configuration -- 3 generated queries -- Includes original query results -- Uses default query generation prompt --} -defaultMultiQueryRetrieverConfig :: MultiQueryRetrieverConfig -defaultMultiQueryRetrieverConfig = - MultiQueryRetrieverConfig - { numQueries = 3 - , queryGenerationPrompt = defaultQueryGenerationPrompt - , includeMergeDocs = True - , includeOriginalQuery = True - } - -{- | Multi-query retriever implementation -Generates multiple queries using an LLM, retrieves documents for each query, -and combines results. Improves recall by exploring different query formulations. - -Example instance: - -@ -mqRetriever = MultiQueryRetriever - { retriever = vectorStoreRetriever - , llm = ollamaLLM - , config = defaultMultiQueryRetrieverConfig - } -@ --} -data (Retriever a, LLM m) => MultiQueryRetriever a m = MultiQueryRetriever - { retriever :: a - -- ^ The base retriever - , llm :: m - -- ^ The language model for generating queries - , config :: MultiQueryRetrieverConfig - -- ^ Configuration - } - -{- | Create retriever with default settings -Example: - ->>> newMultiQueryRetriever vsRetriever ollamaLLM -MultiQueryRetriever {numQueries = 3, ...} --} -newMultiQueryRetriever :: (Retriever a, LLM m) => a -> m -> MultiQueryRetriever a m -newMultiQueryRetriever r l = - MultiQueryRetriever - { retriever = r - , llm = l - , config = defaultMultiQueryRetrieverConfig - } - -{- | Create retriever with custom configuration -Example: - ->>> let customCfg = defaultMultiQueryRetrieverConfig { numQueries = 5 } ->>> newMultiQueryRetrieverWithConfig vsRetriever ollamaLLM customCfg -MultiQueryRetriever {numQueries = 5, ...} --} -newMultiQueryRetrieverWithConfig :: - (Retriever a, LLM m) => - a -> - m -> - MultiQueryRetrieverConfig -> - MultiQueryRetriever a m -newMultiQueryRetrieverWithConfig r l c = - MultiQueryRetriever - { retriever = r - , llm = l - , config = c - } - -{- | Generate multiple query variants using LLM -Example: - ->>> generateQueries ollamaLLM prompt "Haskell" 3 True -Right ["Haskell", "Haskell features", "Haskell applications"] --} -generateQueries :: - LLM m => m -> QueryGenerationPrompt -> Text -> Int -> Bool -> IO (Either LangchainError [Text]) -generateQueries model (QueryGenerationPrompt promptTemplate) query n includeOriginal = do - let vars = HM.fromList [("query", query), ("num_queries", T.pack $ show n)] - case renderPrompt promptTemplate vars of - Left err -> return $ Left err - Right prompt -> do - result <- generate model prompt Nothing - case result of - Left err -> return $ Left err - Right response -> do - case parse response :: Either LangchainError NumberSeparatedList of - Left err -> return $ Left err - Right (NumberSeparatedList queries) -> do - let uniqueQueries = nub $ filter (not . T.null) queries - return $ - Right $ - if includeOriginal - then query : uniqueQueries - else uniqueQueries - -{- | Combine documents from multiple queries -Removes duplicates while maintaining order (simplified approach). --} -combineDocuments :: [[Document]] -> [Document] -combineDocuments docLists = - -- This is a simplified approach. In a production system, you'd want a more - -- sophisticated way to identify and rank duplicate documents - nub $ concat docLists - -{- | Retriever instance implementation -1. Generates multiple queries using LLM -2. Retrieves documents for each query -3. Combines and deduplicates results - -Example retrieval: - ->>> _get_relevant_documents mqRetriever "Haskell" -Right [Document "Haskell is...", Document "Functional programming...", ...] --} -instance (Retriever a, LLM m) => Retriever (MultiQueryRetriever a m) where - _get_relevant_documents r query = do - let baseRetriever = retriever r - model = llm r - cfg = config r - - -- Generate multiple queries - queriesResult <- - generateQueries - model - (queryGenerationPrompt cfg) - query - (numQueries cfg) - (includeOriginalQuery cfg) - - case queriesResult of - Left err -> return $ Left err - Right queries -> do - -- Get documents for each query - results <- mapM (_get_relevant_documents baseRetriever) queries - - -- Filter successful results - let validResults = rights results - - if null validResults - then return $ Left (llmError "No valid results from any query" Nothing Nothing) - else return $ Right $ combineDocuments validResults - -{- - ghci> :set -XOverloadedStrings - ghci> let ollamaEmbed = OllamaEmbeddings "nomic-embed-text:latest" Nothing Nothing - ghci> let vs = emptyInMemoryVectorStore ollamaEmbed - ghci> import Data.Map (empty) - ghci> import Data.Either - ghci> newVs <- addDocuments vs [Document "Tushar is 25 years old." empty] - ghci> let newVs_ = fromRight vs newVs - ghci> let vRet = VectorStoreRetriever newVs_ - ghci> let ollamLLM = Ollama "llama3.2" [] - ghci> let mqRet = newMultiQueryRetriever vRet ollamLLM - ghci> documents <- _get_relevant_documents mqRet "How old is Tushar?" - ghci> documents - Right [Document {pageContent = "Tushar is 25 years old.", metadata = fromList []}] - -} - -{- | Runnable interface implementation -Allows integration with LangChain workflows: - ->>> invoke mqRetriever "AI applications" -Right [Document "Machine learning...", ...] --} -instance (Retriever a, LLM m) => Run.Runnable (MultiQueryRetriever a m) where - type RunnableInput (MultiQueryRetriever a m) = Text - type RunnableOutput (MultiQueryRetriever a m) = [Document] - - invoke = _get_relevant_documents - -{- $examples -Test case patterns: -1. Query generation - >>> generateQueries ollamaLLM prompt "Test" 2 False - Right ["Test case", "Test example"] - -2. Full retrieval flow - >>> _get_relevant_documents mqRetriever "Haskell" - Right [Document "Functional...", Document "Type system..."] - -3. Configuration variants - >>> let cfg = defaultMultiQueryRetrieverConfig { numQueries = 5 } - >>> newMultiQueryRetrieverWithConfig vsRetriever ollamaLLM cfg - MultiQueryRetriever {numQueries = 5, ...} --} diff --git a/src/Langchain/Runnable/Chain.hs b/src/Langchain/Runnable/Chain.hs deleted file mode 100644 --- a/src/Langchain/Runnable/Chain.hs +++ /dev/null @@ -1,267 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -{- | -Module : Langchain.Runnable.Chain -Description : Composition utilities for the Runnable typeclass -Copyright : (c) 2025 Tushar Adhatrao -License : MIT -Maintainer: Tushar Adhatrao - -This module provides various composition patterns for 'Runnable' instances, -allowing you to build complex processing pipelines from simpler components. - -The primary abstractions include: - -* 'RunnableSequence' - Chain multiple runnables sequentially -* 'RunnableBranch' - Select different processing branches based on input conditions -* 'RunnableMap' - Transform inputs or outputs when composing runnables - -These abstractions follow functional programming patterns to create flexible -data processing pipelines for language model applications. --} -module Langchain.Runnable.Chain - ( -- * Core Data Types - RunnableBranch (..) - , RunnableMap (..) - , RunnableSequence - - -- * Execution Functions - , runBranch - , runMap - , runSequence - - -- * Composition Utilities - , chain - , branch - , buildSequence - , appendSequence - , (|>>) - ) where - -import Data.List (find) -import Langchain.Error (LangchainError) -import Langchain.Runnable.Core - -{- | Chains two 'Runnable' instances together sequentially. - -The output of the first runnable is fed as input to the second. -If the first runnable fails, the error is returned immediately. - ->>> :{ -let textSplitter = TextSplitter defaultConfig - llm = OpenAI defaultConfig - summarizer input = chain textSplitter llm input -in summarizer "Split this text and then summarize each part." -:} -Right "The text was split into chunks and each part was summarized." --} -chain :: - (Runnable r1, Runnable r2, RunnableOutput r1 ~ RunnableInput r2) => - r1 -> - r2 -> - RunnableInput r1 -> - IO (Either LangchainError (RunnableOutput r2)) -chain r1 r2 input = do - output1 <- invoke r1 input - case output1 of - Left err -> return $ Left err - Right intermediate -> invoke r2 intermediate - -{- | Creates a parallel composition of two 'Runnable' instances. - -Both runnables receive the same input and their outputs are combined -into a tuple. If either runnable fails, the combined result fails. - ->>> :{ -let sentimentAnalyzer = LLMChain "Analyze sentiment of this text" - keywordExtractor = LLMChain "Extract keywords from this text" - analyzer text = branch sentimentAnalyzer keywordExtractor text -in analyzer "I love Haskell but monads can be challenging at first." -:} -Right ("Positive", ["Haskell", "love", "monads", "challenging"]) --} -branch :: - (Runnable r1, Runnable r2, a ~ RunnableInput r1, a ~ RunnableInput r2) => - r1 -> - r2 -> - a -> - IO (Either LangchainError (RunnableOutput r1, RunnableOutput r2)) -branch r1 r2 input = do - result1 <- invoke r1 input - result2 <- invoke r2 input - return $ (,) <$> result1 <*> result2 - -{- | A conditional branching structure for 'Runnable' instances. - -'RunnableBranch' allows you to specify multiple condition-runnable pairs, -where the first runnable whose condition matches the input is invoked. -If no condition matches, a default runnable is used. - -The conditions are functions that evaluate the input and return a boolean. --} -data RunnableBranch a b - = forall r. - (Runnable r, RunnableInput r ~ a, RunnableOutput r ~ b) => - RunnableBranch [(a -> Bool, r)] r -- List of (condition, runnable) pairs and a default runnable - -{- | Executes a 'RunnableBranch' by selecting the first matching runnable. - -Evaluates each condition in order until one returns 'True', then invokes -the corresponding runnable. If no condition matches, invokes the default runnable. - ->>> :{ -let isShort text = length text < 100 - isQuestion text = last text == '?' - shortTextHandler = LLMChain "Process short text" - questionHandler = LLMChain "Answer the question" - defaultHandler = LLMChain "Process general text" - textProcessor = RunnableBranch [(isShort, shortTextHandler), (isQuestion, questionHandler)] defaultHandler -in runBranch textProcessor "How does this work?" -:} -Right "This is a question, so I'm handling it with the question processor." --} -runBranch :: RunnableBranch a b -> a -> IO (Either LangchainError b) -runBranch (RunnableBranch options defaultR) input = - case find (\(cond, _) -> cond input) options of - Just (_, r) -> invoke r input - Nothing -> invoke defaultR input - -instance Runnable (RunnableBranch a b) where - type RunnableInput (RunnableBranch a b) = a - type RunnableOutput (RunnableBranch a b) = b - - invoke = runBranch - -{- | A 'Runnable' that transforms input and/or output when executing another 'Runnable'. - -'RunnableMap' allows you to adapt the input or output types of an existing 'Runnable' -to make it compatible with other components in your processing pipeline. --} -data RunnableMap a b c - = forall r. - (Runnable r, RunnableInput r ~ b, RunnableOutput r ~ c) => - RunnableMap (a -> b) (c -> c) r -- input transform, output transform, and the runnable - -{- | Executes a 'RunnableMap' by applying transformations to input and output. - -First applies the input transformation function, then invokes the wrapped runnable, -and finally applies the output transformation function to the result (if successful). - ->>> :{ -let extractLength = length :: String -> Int - isPalindrome str = str == reverse str - lengthPalindrome = RunnableMap extractLength isPalindrome (pure True) -in runMap lengthPalindrome "hello" -:} -Right False --} -runMap :: RunnableMap a b c -> a -> IO (Either LangchainError c) -runMap (RunnableMap inputFn outputFn r) input = do - result <- invoke r (inputFn input) - return $ fmap outputFn result - -instance Runnable (RunnableMap a b c) where - type RunnableInput (RunnableMap a b c) = a - type RunnableOutput (RunnableMap a b c) = c - - invoke = runMap - -{- | A sequence of 'Runnable' instances chained together. - -'RunnableSequence' represents a pipeline where the output of each 'Runnable' -becomes the input to the next. This is the core abstraction for building -processing pipelines in Langchain. - -The GADT construction ensures that the output type of each component -matches the input type of the next component. --} -data RunnableSequence a b where - RSNil :: RunnableSequence a a -- the empty chain, where the input and output types are the same. - RSCons :: - (Runnable r, RunnableInput r ~ a, RunnableOutput r ~ c) => - r -> - RunnableSequence c b -> - RunnableSequence a b -- RSCons adds a runnable at the front of the chain. - --- | Run a sequence of runnables, chaining the output of one as input to the next. -runSequence :: RunnableSequence a b -> RunnableInputHead a -> IO (Either LangchainError b) -runSequence RSNil input = return (Right input) -runSequence (RSCons r rs) input = do - result <- invoke r input - case result of - Left err -> return (Left err) - Right out -> runSequence rs out - -instance Runnable (RunnableSequence a b) where - type RunnableInput (RunnableSequence a b) = a - type RunnableOutput (RunnableSequence a b) = b - - invoke = runSequence - --- | A type synonym to indicate the input type of the first runnable. -type RunnableInputHead a = a - -{- | Builds a 'RunnableSequence' from two 'Runnable' instances. - -This is a convenience function for creating a simple two-component sequence. - ->>> :{ -let parser = JSONParser defaultConfig - validator = SchemaValidator personSchema - personProcessor = buildSequence parser validator -in invoke personProcessor "{\"name\":\"John\",\"age\":30}" -:} -Right (Person "John" 30) --} -buildSequence :: - ( Runnable r1 - , Runnable r2 - , RunnableOutput r1 ~ RunnableInput r2 - ) => - r1 -> - r2 -> - RunnableSequence (RunnableInput r1) (RunnableOutput r2) -buildSequence r1 r2 = RSCons r1 (RSCons r2 RSNil) - -{- | Appends a 'Runnable' to the end of a 'RunnableSequence'. - -This allows you to incrementally build longer processing pipelines. - ->>> :{ -let retriever = DocumentRetriever defaultConfig - llm = OpenAI defaultConfig - formatter = OutputFormatter defaultConfig - basePipeline = buildSequence retriever llm - fullPipeline = appendSequence basePipeline formatter -in invoke fullPipeline "Tell me about Haskell's type system" -:} -Right "Haskell has a strong, static type system featuring type inference..." --} -appendSequence :: - ( Runnable r2 - , RunnableOutput (RunnableSequence a b) ~ RunnableInput r2 - ) => - RunnableSequence a b -> - r2 -> - RunnableSequence a (RunnableOutput r2) -appendSequence RSNil r = RSCons r RSNil -appendSequence (RSCons r1 rs) r2 = RSCons r1 (appendSequence rs r2) - -{- | Operator version of 'chain' for more readable composition. - -Allows for cleaner pipeline construction with an infix operator: - ->>> textSplitter |>> embedder |>> retriever |>> llm $ "Explain monads in Haskell." -Right "Monads in Haskell are a design pattern that allows for sequencing computations..." --} -(|>>) :: - (Runnable r1, Runnable r2, RunnableOutput r1 ~ RunnableInput r2) => - r1 -> - r2 -> - RunnableInput r1 -> - IO (Either LangchainError (RunnableOutput r2)) -(|>>) = chain - -infix 4 |>> diff --git a/src/Langchain/Runnable/ConversationChain.hs b/src/Langchain/Runnable/ConversationChain.hs deleted file mode 100644 --- a/src/Langchain/Runnable/ConversationChain.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -{- | -Module : Langchain.Runnable.ConversationChain -Description : Stateful conversation handler for LLM interactions -Copyright : (c) 2025 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao - -Note: This module is not functional at this moment. - -This module provides the 'ConversationChain' implementation, which manages stateful -conversations with language models. It combines: - -1. A memory component for storing conversation history -2. An LLM for generating responses -3. A prompt template for formatting the conversation - -'ConversationChain' handles the full conversation lifecycle, including: - -- Adding user messages to memory -- Retrieving conversation history -- Formatting the conversation context for the LLM -- Getting responses from the LLM -- Storing AI responses back to memory - -This creates a complete conversation loop that maintains context across multiple turns. --} -module Langchain.Runnable.ConversationChain - ( -- * Types - ConversationChain (..) - ) where - -import Control.Monad.Trans.Except -import Data.Text (Text) -import Langchain.LLM.Core -import Langchain.Memory.Core -import Langchain.PromptTemplate -import Langchain.Runnable.Core - -{- | Manages a stateful conversation between a user and a language model. - -The 'ConversationChain' combines three key components: - -1. @memory@: Stores and retrieves conversation history -2. @llm@: The language model that generates responses -3. @prompt@: Template for formatting the conversation for the LLM - -When invoked with a user message, the 'ConversationChain': - -- Adds the user message to memory -- Retrieves the updated conversation history -- Formats the conversation for the LLM using the prompt template -- Gets a response from the LLM -- Stores the AI response in memory -- Returns the AI response - -Example: - -@ -import Data.Text (Text) -import qualified Data.Text as T -import Langchain.LLM.OpenAI (OpenAI(..)) -import Langchain.Memory.ConversationBufferMemory (ConversationBufferMemory(..)) -import Langchain.PromptTemplate (PromptTemplate(..), createPromptTemplate) -import Langchain.Runnable.ConversationChain (ConversationChain(..)) - -main :: IO () -main = do - -- Create memory component - let memory = ConversationBufferMemory - { messages = [] - , returnMessages = True - } - - -- Create LLM - let llm = OpenAI - { model = "gpt-4" - , temperature = 0.7 - } - - -- Create prompt template - promptTemplate <- createPromptTemplate - "You are a helpful assistant. {history}\\nHuman: {input}\\nAI:" - ["history", "input"] - - -- Create conversation chain - let conversation = ConversationChain - { memory = memory - , llm = llm - , prompt = promptTemplate - } - - -- Start conversation - response1 <- invoke conversation "Hello, who are you?" - case response1 of - Left err -> putStrLn $ "Error: " ++ T.unpack err - Right answer -> do - putStrLn $ "AI: " ++ T.unpack answer - - -- Continue conversation with context - response2 <- invoke conversation "What can you help me with?" - case response2 of - Left err -> putStrLn $ "Error: " ++ T.unpack err - Right answer2 -> putStrLn $ "AI: " ++ T.unpack answer2 -@ - -You can customize the behavior by using different memory implementations: - -* 'ConversationBufferMemory' - Stores the full conversation history -* 'ConversationBufferWindowMemory' - Keeps only the most recent N exchanges -* 'ConversationSummaryMemory' - Summarizes older conversations to save tokens -* 'ConversationEntityMemory' - Tracks entities mentioned in the conversation - -The prompt template can be customized to give the LLM specific instructions, -persona characteristics, or to format the conversation history in different ways. --} -data ConversationChain m l = ConversationChain - { memory :: m - -- ^ Memory component that stores conversation history - , llm :: l - -- ^ Language model that generates responses - , prompt :: PromptTemplate - -- ^ Template for formatting the conversation - } - --- | Make ConversationChain an instance of Runnable to enable composition with other components -instance (BaseMemory m, LLM l) => Runnable (ConversationChain m l) where - type RunnableInput (ConversationChain m l) = Text - type RunnableOutput (ConversationChain m l) = Text - - -- \| Process a user message and generate an AI response. - -- - -- This method: - -- 1. Adds the user message to memory - -- 2. Retrieves the full conversation history - -- 3. Formats the history and input for the LLM - -- 4. Gets a response from the LLM - -- 5. Stores the AI response in memory - -- 6. Returns the AI response - -- - -- Example: - -- - -- @ - -- let chatbot = ConversationChain { ... } - -- - -- -- Single turn conversation - -- response <- invoke chatbot "Can you explain monads in Haskell?" - -- - -- -- Multi-turn conversation with context - -- response1 <- invoke chatbot "Who was Alan Turing?" - -- response2 <- invoke chatbot "What was his most famous contribution?" - -- response3 <- invoke chatbot "Can you explain it in simpler terms?" - -- @ - -- - invoke chain input = runExceptT $ do - updatedMem <- ExceptT $ addUserMessage (memory chain) input - allMessages <- ExceptT $ messages updatedMem - response <- ExceptT $ chat (llm chain) allMessages Nothing - _ <- ExceptT $ addAiMessage updatedMem (content response) - return $ content response diff --git a/src/Langchain/Runnable/Core.hs b/src/Langchain/Runnable/Core.hs deleted file mode 100644 --- a/src/Langchain/Runnable/Core.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -{- | -Module : Langchain.Runnable.Core -Description : Core Interface of Runnable. Necessary for LangChain Expression Language (LCEL) -Copyright : (c) 2025 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao - -This module defines the 'Runnable' typeclass, which is the fundamental abstraction in the -Haskell implementation of LangChain Expression Language (LCEL). A 'Runnable' represents any -component that can process an input and produce an output, potentially with side effects. - -The 'Runnable' abstraction enables composition of various LLM-related components into -processing pipelines, including: - -* Language Models -* Prompt Templates -* Document Retrievers -* Text Splitters -* Embedders -* Vector Stores -* Output Parsers - -By implementing the 'Runnable' typeclass, components can be combined using the combinators -provided in "Langchain.Runnable.Chain". --} -module Langchain.Runnable.Core - ( Runnable (..) - ) where - -import Control.Monad.IO.Class (MonadIO, liftIO) -import Langchain.Error (LangchainResult) - -{- | The core 'Runnable' typeclass represents anything that can "run" with an input and produce an output. - -This typeclass is the foundation of the LangChain Expression Language (LCEL) in Haskell, -allowing different components to be composed into processing pipelines. - -To implement a 'Runnable', you must: - -1. Define the input and output types using associated type families -2. Implement the 'invoke' method -3. Optionally override 'batch' and 'stream' for specific optimizations - -Example implementation: - -@ -data TextSplitter = TextSplitter { chunkSize :: Int, overlap :: Int } - -instance Runnable TextSplitter where - type RunnableInput TextSplitter = String - type RunnableOutput TextSplitter = [String] - - invoke splitter text = do - -- Implementation of text splitting logic - let chunks = splitTextIntoChunks (chunkSize splitter) (overlap splitter) text - return $ Right chunks -@ --} -class Runnable r where - {- | The type of input the runnable accepts. - - For example, an LLM might accept 'String' or 'PromptValue' as input. - -} - type RunnableInput r - - {- | The type of output the runnable produces. - - For example, an LLM might produce 'String' or 'LLMResult' as output. - -} - type RunnableOutput r - - {- | Core method to invoke (run) this component with a single input. - - This is the primary method that must be implemented for any 'Runnable'. - It processes a single input and returns either an error message or the output. - - Example usage: - - @ - let model = OpenAI { temperature = 0.7, model = "gpt-3.5-turbo" } - result <- invoke model "Explain monads in simple terms." - case result of - Left err -> putStrLn $ "Error: " ++ err - Right response -> putStrLn response - @ - -} - invoke :: r -> RunnableInput r -> IO (LangchainResult (RunnableOutput r)) - - invokeM :: MonadIO m => r -> RunnableInput r -> m (LangchainResult (RunnableOutput r)) - invokeM runnable input = liftIO $ invoke runnable input - - batch :: r -> [RunnableInput r] -> IO (LangchainResult [RunnableOutput r]) - - batchM :: MonadIO m => r -> [RunnableInput r] -> m (LangchainResult [RunnableOutput r]) - batchM runnable inputs = liftIO $ batch runnable inputs - - -- | Default implementation of batch that processes each input sequentially - batch r inputs = do - results <- mapM (invoke r) inputs - return $ sequence results - - stream :: r -> RunnableInput r -> (RunnableOutput r -> IO ()) -> IO (LangchainResult ()) - - -- | Default implementation that invokes the runnable and then calls the callback with the full result - stream r input callback = do - result <- invoke r input - case result of - Left err -> return $ Left err - Right output -> do - callback output - return $ Right () - - streamM :: - MonadIO m => r -> RunnableInput r -> (RunnableOutput r -> IO ()) -> m (LangchainResult ()) - streamM runnable input callback = liftIO $ stream runnable input callback diff --git a/src/Langchain/Runnable/Utils.hs b/src/Langchain/Runnable/Utils.hs deleted file mode 100644 --- a/src/Langchain/Runnable/Utils.hs +++ /dev/null @@ -1,247 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -{- | -Module : Langchain.Runnable.Utils -Description : Utility wrappers for Runnable components in LangChain -Copyright : (c) 2025 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao - -This module provides various utility wrappers for 'Runnable' components that enhance -their behavior with common patterns like: - -* Configuration management -* Result caching -* Automatic retries -* Timeout handling - -These utilities follow the decorator pattern, wrapping existing 'Runnable' instances -with additional functionality while preserving the original input/output types. - -Note: This module is experimental and the API may change in future versions. --} -module Langchain.Runnable.Utils - ( -- * Configuration Management - WithConfig (..) - - -- * Caching - , Cached (..) - , cached - - -- * Resilience Patterns - , Retry (..) - , WithTimeout (..) - ) where - -import Control.Concurrent -import Data.Map.Strict as Map -import Langchain.Error (llmError) -import Langchain.Runnable.Core - -{- | Wrapper for 'Runnable' components with configurable behavior. - -This wrapper allows attaching configuration data to a 'Runnable' instance. -The configuration data can be accessed and modified without changing the -underlying 'Runnable' implementation. - -Example: - -@ -data LLMConfig = LLMConfig - { temperature :: Float - , maxTokens :: Int - } - -let - baseModel = OpenAI defaultOpenAIConfig - configuredModel = WithConfig - { configuredRunnable = baseModel - , runnableConfig = LLMConfig 0.7 100 - } - --- Later, modify the configuration without changing the model -let updatedModel = configuredModel { runnableConfig = LLMConfig 0.9 150 } - --- Use the model as a regular Runnable -result <- invoke updatedModel "Explain monads in Haskell" -@ --} -data WithConfig config r - = (Runnable r) => - WithConfig - { configuredRunnable :: r - -- ^ The wrapped 'Runnable' instance - , runnableConfig :: config - -- ^ Configuration data for this 'Runnable' - } - --- | Make WithConfig a Runnable that applies the configuration -instance (Runnable r) => Runnable (WithConfig config r) where - type RunnableInput (WithConfig config r) = RunnableInput r - type RunnableOutput (WithConfig config r) = RunnableOutput r - - invoke (WithConfig r1 _) = invoke r1 - -{- | Cache results of a 'Runnable' to avoid duplicate computations. - -This wrapper stores previously computed results in a thread-safe cache. -When an input is encountered again, the cached result is returned instead -of recomputing it, which can significantly improve performance for expensive -operations or when the same inputs are frequently processed. - -Note: The cached results are stored in-memory and will be lost when the program -terminates. For persistent caching, consider implementing a custom wrapper that -uses database storage. - -The 'RunnableInput' type must be an instance of 'Ord' for map lookups. --} -data Cached r - = (Runnable r, Ord (RunnableInput r)) => - Cached - { cachedRunnable :: r - -- ^ The wrapped 'Runnable' instance - , cacheMap :: MVar (Map.Map (RunnableInput r) (RunnableOutput r)) - -- ^ Thread-safe cache storage - } - -cached :: (Runnable r, Ord (RunnableInput r)) => r -> IO (Cached r) -cached r = do - cache <- newMVar Map.empty - return $ Cached r cache - --- | Make Cached a Runnable that uses a cache -instance (Runnable r, Ord (RunnableInput r)) => Runnable (Cached r) where - type RunnableInput (Cached r) = RunnableInput r - type RunnableOutput (Cached r) = RunnableOutput r - - invoke (Cached r cacheRef) input = do - cache <- readMVar cacheRef - case Map.lookup input cache of - Just output -> return $ Right output -- Cache hit: return cached result - Nothing -> do - -- Cache miss: compute and store resul - result <- invoke r input - case result of - Left err -> return $ Left err - Right output -> do - modifyMVar_ cacheRef $ \c -> return $ Map.insert input output c - return $ Right output - -{- | Add retry capability to any 'Runnable'. - -This wrapper automatically retries failed operations up to a specified -number of times with a configurable delay between attempts. This is particularly -useful for network operations or external API calls that might fail transiently. - -Example: - -@ --- Create an LLM with automatic retry for network failures -let - baseModel = OpenAI defaultConfig - resilientModel = Retry - { retryRunnable = baseModel - , maxRetries = 3 - , retryDelay = 1000000 -- 1 second delay between retries - } - --- If the API call fails, it will retry up to 3 times -result <- invoke resilientModel "Generate a story about a Haskell programmer" -@ --} -data Retry r - = (Runnable r) => - Retry - { retryRunnable :: r - -- ^ The wrapped 'Runnable' instance - , maxRetries :: Int - -- ^ Maximum number of retry attempts - , retryDelay :: Int - -- ^ Delay between retry attempts in microseconds - } - --- | Make Retry a Runnable that retries on failure -instance (Runnable r) => Runnable (Retry r) where - type RunnableInput (Retry r) = RunnableInput r - type RunnableOutput (Retry r) = RunnableOutput r - - invoke (Retry r maxRetries_ delay) input = retryWithCount 0 - where - retryWithCount count = do - result <- invoke r input - case result of - Left err -> - if count < maxRetries_ - then do - threadDelay delay - retryWithCount (count + 1) - else return $ Left err - Right output -> return $ Right output - -{- | Add timeout capability to any 'Runnable'. - -This wrapper enforces a maximum execution time for the wrapped 'Runnable'. -If the operation takes longer than the specified timeout, it is cancelled and -an error is returned. This is useful for limiting the execution time of potentially -long-running operations. - -Example: - -@ --- Create an LLM with a 30-second timeout -let - baseModel = OpenAI defaultConfig - timeboxedModel = WithTimeout - { timeoutRunnable = baseModel - , timeoutMicroseconds = 30000000 -- 30 seconds - } - --- If the API call takes longer than 30 seconds, it will be cancelled -result <- invoke timeboxedModel "Generate a detailed analysis of Haskell's type system" -@ - -Note: This implementation uses 'forkIO' and 'killThread', which may not always -cleanly terminate the underlying operation, especially for certain types of I/O. -For critical applications, consider implementing a more robust timeout mechanism. --} -data WithTimeout r - = (Runnable r) => - WithTimeout - { timeoutRunnable :: r - -- ^ The wrapped 'Runnable' instance - , timeoutMicroseconds :: Int - -- ^ Timeout duration in microseconds - } - --- | Make WithTimeout a Runnable that times out -instance (Runnable r) => Runnable (WithTimeout r) where - type RunnableInput (WithTimeout r) = RunnableInput r - type RunnableOutput (WithTimeout r) = RunnableOutput r - - invoke (WithTimeout r timeout) input = do - resultVar <- newEmptyMVar - - -- Fork a thread to run the computation - tid <- forkIO $ do - result <- invoke r input - putMVar resultVar (Just result) - - -- Set up the timeout - timeoutTid <- forkIO $ do - threadDelay timeout - putMVar resultVar Nothing - - -- Wait for either result or timeout - result <- takeMVar resultVar - - -- Kill the other thread - killThread tid - killThread timeoutTid - - case result of - Just r_ -> return r_ - Nothing -> return $ Left (llmError "Operation timed out" Nothing Nothing) diff --git a/src/Langchain/TextSplitter/Code.hs b/src/Langchain/TextSplitter/Code.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/TextSplitter/Code.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Langchain.TextSplitter.Code +Description : Language-aware code text splitter +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Splits programming language source code at top-level declarations, class/function +boundaries, or language-specific constructs. +-} +module Langchain.TextSplitter.Code + ( Language (..) + , CodeSplitterOps (..) + , defaultCodeSplitterOps + , languageSeparators + , splitCode + ) where + +import Data.Int (Int64) +import Data.Text.Lazy (Text) + +import Langchain.TextSplitter.RecursiveCharacter + ( RecursiveCharacterSplitterOps (..) + , splitTextRecursive + ) + +-- | Supported programming languages for code splitting +data Language + = Haskell + | Python + | JavaScript + | TypeScript + | Rust + | Go + | Java + | Cpp + | CSharp + | MarkdownCode + deriving (Show, Eq, Enum, Bounded) + +-- | Configuration options for code splitting +data CodeSplitterOps = CodeSplitterOps + { codeLanguage :: Language + , codeChunkSize :: Int64 + , codeChunkOverlap :: Int64 + } + deriving (Show, Eq) + +-- | Return language-specific separator hierarchy +languageSeparators :: Language -> [Text] +languageSeparators Haskell = + [ "\nmodule " + , "\ndata " + , "\nnewtype " + , "\ntype " + , "\nclass " + , "\ninstance " + , "\n\n" + , "\n" + , " " + , "" + ] +languageSeparators Python = + [ "\nclass " + , "\ndef " + , "\n\tdef " + , "\n\n" + , "\n" + , " " + , "" + ] +languageSeparators JavaScript = + [ "\nfunction " + , "\nclass " + , "\nexport default " + , "\nexport const " + , "\nconst " + , "\nlet " + , "\nvar " + , "\n\n" + , "\n" + , " " + , "" + ] +languageSeparators TypeScript = languageSeparators JavaScript +languageSeparators Rust = + [ "\nfn " + , "\npub fn " + , "\nstruct " + , "\npub struct " + , "\nenum " + , "\npub enum " + , "\nimpl " + , "\ntrait " + , "\n\n" + , "\n" + , " " + , "" + ] +languageSeparators Go = + [ "\nfunc " + , "\ntype " + , "\n\n" + , "\n" + , " " + , "" + ] +languageSeparators Java = + [ "\npublic class " + , "\nclass " + , "\npublic interface " + , "\ninterface " + , "\npublic enum " + , "\npublic " + , "\nprivate " + , "\nprotected " + , "\n\n" + , "\n" + , " " + , "" + ] +languageSeparators Cpp = + [ "\nclass " + , "\nstruct " + , "\nenum " + , "\ntemplate " + , "\n\n" + , "\n" + , " " + , "" + ] +languageSeparators CSharp = languageSeparators Java +languageSeparators MarkdownCode = + [ "\n# " + , "\n## " + , "\n### " + , "\n#### " + , "\n```" + , "\n\n" + , "\n" + , " " + , "" + ] + +-- | Default code splitter options for a language +defaultCodeSplitterOps :: Language -> CodeSplitterOps +defaultCodeSplitterOps lang = + CodeSplitterOps + { codeLanguage = lang + , codeChunkSize = 1000 + , codeChunkOverlap = 150 + } + +-- | Split code using language-specific syntax separators +splitCode :: CodeSplitterOps -> Text -> [Text] +splitCode ops text = + let seps = languageSeparators (codeLanguage ops) + recOps = + RecursiveCharacterSplitterOps + { chunkSize = codeChunkSize ops + , chunkOverlap = codeChunkOverlap ops + , separators = seps + } + in splitTextRecursive recOps text diff --git a/src/Langchain/TextSplitter/Markdown.hs b/src/Langchain/TextSplitter/Markdown.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/TextSplitter/Markdown.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Langchain.TextSplitter.Markdown +Description : Markdown document header-aware text splitter +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Splits markdown text based on structural headers (# Header 1, ## Header 2, etc.) +and generates chunks with inherited header context. +-} +module Langchain.TextSplitter.Markdown + ( MarkdownSplitterOps (..) + , MarkdownChunk (..) + , defaultMarkdownSplitterOps + , splitMarkdown + , splitMarkdownToChunks + ) where + +import Data.Int (Int64) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T + +import Langchain.TextSplitter.RecursiveCharacter + ( RecursiveCharacterSplitterOps (..) + , defaultRecursiveCharacterSplitterOps + , splitTextRecursive + ) + +-- | Represents a chunk of markdown text with its associated header hierarchy +data MarkdownChunk = MarkdownChunk + { chunkContent :: Text + , chunkHeaders :: Map Text Text + } + deriving (Show, Eq) + +-- | Configuration options for markdown text splitting +data MarkdownSplitterOps = MarkdownSplitterOps + { mdChunkSize :: Int64 + , mdChunkOverlap :: Int64 + , headersToSplitOn :: [(Text, Text)] -- e.g. [("#", "Header 1"), ("##", "Header 2"), ("###", "Header 3")] + } + deriving (Show, Eq) + +-- | Default markdown splitter options +defaultMarkdownSplitterOps :: MarkdownSplitterOps +defaultMarkdownSplitterOps = + MarkdownSplitterOps + { mdChunkSize = 1000 + , mdChunkOverlap = 100 + , headersToSplitOn = + [ ("#", "Header 1") + , ("##", "Header 2") + , ("###", "Header 3") + , ("####", "Header 4") + ] + } + +-- | Split markdown document into MarkdownChunks with header metadata +splitMarkdownToChunks :: MarkdownSplitterOps -> Text -> [MarkdownChunk] +splitMarkdownToChunks _ "" = [] +splitMarkdownToChunks ops text = + let rawLines = T.lines text + sections = groupLinesByHeaders (headersToSplitOn ops) Map.empty rawLines + in concatMap (subSplitSection ops) sections + +-- | Split markdown text into plain Text chunks +splitMarkdown :: MarkdownSplitterOps -> Text -> [Text] +splitMarkdown ops text = map chunkContent (splitMarkdownToChunks ops text) + +-- Group lines into header-annotated sections +groupLinesByHeaders :: [(Text, Text)] -> Map Text Text -> [Text] -> [MarkdownChunk] +groupLinesByHeaders _ _ [] = [] +groupLinesByHeaders headerRules currentHeaders ls = go currentHeaders [] ls + where + go :: Map Text Text -> [Text] -> [Text] -> [MarkdownChunk] + go hdrs acc [] = [MarkdownChunk (T.unlines (reverse acc)) hdrs | not (null acc)] + go hdrs acc (l : rest) = + case matchHeader headerRules l of + Just (hPrefix, hName, hTitle) -> + let currentChunk = [MarkdownChunk (T.unlines (reverse acc)) hdrs | not (null acc)] + -- update headers: clear deeper headers when higher header occurs + newHdrs = updateHeaderMap headerRules hPrefix hName hTitle hdrs + in currentChunk ++ go newHdrs [l] rest + Nothing -> + go hdrs (l : acc) rest + +matchHeader :: [(Text, Text)] -> Text -> Maybe (Text, Text, Text) +matchHeader rules line = + let stripped = T.stripStart line + in findRule rules stripped + where + findRule [] _ = Nothing + findRule ((prefix, name) : rs) s = + let prefixWithSpace = prefix <> " " + in if prefixWithSpace `T.isPrefixOf` s + then Just (prefix, name, T.strip (T.drop (T.length prefixWithSpace) s)) + else findRule rs s + +updateHeaderMap :: [(Text, Text)] -> Text -> Text -> Text -> Map Text Text -> Map Text Text +updateHeaderMap rules prefix name title curMap = + let prefixDepth = T.length prefix + -- keep only headers with depth < prefixDepth + filtered = + Map.filterWithKey + ( \k _ -> case lookupPrefixKey rules k of + Just p -> T.length p < prefixDepth + Nothing -> True + ) + curMap + in Map.insert name title filtered + +lookupPrefixKey :: [(Text, Text)] -> Text -> Maybe Text +lookupPrefixKey [] _ = Nothing +lookupPrefixKey ((p, n) : rest) name + | n == name = Just p + | otherwise = lookupPrefixKey rest name + +subSplitSection :: MarkdownSplitterOps -> MarkdownChunk -> [MarkdownChunk] +subSplitSection ops (MarkdownChunk content hdrs) = + let cSize = mdChunkSize ops + cOverlap = mdChunkOverlap ops + in if T.length content <= cSize + then [MarkdownChunk content hdrs] + else + let subOps = + defaultRecursiveCharacterSplitterOps + { chunkSize = cSize + , chunkOverlap = cOverlap + , separators = ["\n\n", "\n", " ", ""] + } + subPieces = splitTextRecursive subOps content + in [MarkdownChunk piece hdrs | piece <- subPieces] diff --git a/src/Langchain/TextSplitter/RecursiveCharacter.hs b/src/Langchain/TextSplitter/RecursiveCharacter.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/TextSplitter/RecursiveCharacter.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Langchain.TextSplitter.RecursiveCharacter +Description : Hierarchical recursive character text splitting with chunk overlap +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Recursively splits text by trying different separators in order (paragraphs, lines, spaces, characters) +to keep semantically related pieces of text together. +-} +module Langchain.TextSplitter.RecursiveCharacter + ( RecursiveCharacterSplitterOps (..) + , defaultRecursiveCharacterSplitterOps + , splitTextRecursive + ) +where + +import Data.Int (Int64) +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T + +-- | Configuration options for recursive character text splitter +data RecursiveCharacterSplitterOps = RecursiveCharacterSplitterOps + { chunkSize :: Int64 + , chunkOverlap :: Int64 + , separators :: [Text] + } + deriving (Show, Eq) + +-- | Default options: 1000 char chunks, 200 char overlap, standard hierarchy of separators +defaultRecursiveCharacterSplitterOps :: RecursiveCharacterSplitterOps +defaultRecursiveCharacterSplitterOps = + RecursiveCharacterSplitterOps + { chunkSize = 1000 + , chunkOverlap = 200 + , separators = ["\n\n", "\n", " ", ""] + } + +-- | Split text recursively using the specified separators hierarchy +splitTextRecursive :: RecursiveCharacterSplitterOps -> Text -> [Text] +splitTextRecursive _ "" = [] +splitTextRecursive + RecursiveCharacterSplitterOps + { chunkSize = maxSize + , chunkOverlap = maxOverlap + , separators = ss + } + text = splitRecursive ss text + where + splitRecursive :: [Text] -> Text -> [Text] + splitRecursive [] txt = splitByLen txt + splitRecursive ("" : _) txt = splitByLen txt + splitRecursive (sep : seps) txt = mergeWithOverlap sep splitParts + where + splitParts = concatMap (splitRecursive seps) $ filter (not . T.null) $ T.splitOn sep txt + + splitByLen :: Text -> [Text] + splitByLen "" = [] + splitByLen txt = chunk : splitByLen remainder + where + (chunk, remainder) = T.splitAt maxSize txt + + mergeWithOverlap :: Text -> [Text] -> [Text] + mergeWithOverlap _ [] = [] + mergeWithOverlap sep parts = reverse $ go [] 0 [] parts + where + sepLen = T.length sep + toText = T.intercalate sep . reverse + + go :: [Text] -> Int64 -> [Text] -> [Text] -> [Text] + go acc chunkLen chunkParts pss = + case pss of + [] -> acc' + (part : restParts) -> + let partLen = T.length part + chunkLen' = chunkLen + sepBefore chunkParts + partLen + in if chunkLen' <= maxSize + then go acc chunkLen' (part : chunkParts) restParts + else + let (overlapParts, overlapLen) = takeWhileOverlap chunkParts 0 [] + carryLen = overlapLen + sepBefore overlapParts + partLen + in go acc' carryLen (part : reverse overlapParts) restParts + where + acc' = toText chunkParts : acc + + sepBefore ps = if null ps then 0 else sepLen + + takeWhileOverlap [] overlapLen overlapAcc = (overlapAcc, overlapLen) + takeWhileOverlap (overlapPart : restOverlap) overlapLen overlapAcc + | overlapLen' > maxOverlap = (overlapAcc, overlapLen) + | otherwise = takeWhileOverlap restOverlap overlapLen' (overlapPart : overlapAcc) + where + overlapLen' = overlapLen + sepBefore overlapAcc + T.length overlapPart diff --git a/src/Langchain/TextSplitter/Token.hs b/src/Langchain/TextSplitter/Token.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/TextSplitter/Token.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Langchain.TextSplitter.Token +Description : Token-based text splitting with configurable token counter +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Splits text into chunks of specified maximum token counts with optional overlap. +-} +module Langchain.TextSplitter.Token + ( TokenSplitterOps (..) + , defaultTokenSplitterOps + , splitByTokens + , countTokensApprox + ) where + +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T + +-- | Configuration options for token-based text splitting +data TokenSplitterOps = TokenSplitterOps + { maxTokens :: Int + , tokenOverlap :: Int + , tokenCounter :: Text -> Int + } + +instance Show TokenSplitterOps where + show ops = + "TokenSplitterOps { maxTokens = " + ++ show (maxTokens ops) + ++ ", tokenOverlap = " + ++ show (tokenOverlap ops) + ++ " }" + +-- | Approximate token count (roughly 4 characters per token or word-based heuristic) +countTokensApprox :: Text -> Int +countTokensApprox t = + let wCount = length (T.words t) + cCount = fromIntegral (T.length t) `div` 4 + in max wCount cCount + +-- | Default token splitter options (500 tokens, 50 token overlap) +defaultTokenSplitterOps :: TokenSplitterOps +defaultTokenSplitterOps = + TokenSplitterOps + { maxTokens = 500 + , tokenOverlap = 50 + , tokenCounter = countTokensApprox + } + +-- | Split text into chunks bounded by maxTokens +splitByTokens :: TokenSplitterOps -> Text -> [Text] +splitByTokens _ "" = [] +splitByTokens ops text = + let wordsList = T.words text + in if null wordsList + then [] + else go [] [] wordsList + where + maxT = maxTokens ops + overlapT = tokenOverlap ops + count = tokenCounter ops + + go :: [Text] -> [Text] -> [Text] -> [Text] + go acc currentWords [] = + if null currentWords + then reverse acc + else reverse (T.unwords (reverse currentWords) : acc) + go acc currentWords (w : ws) = + let candidate = T.unwords (reverse (w : currentWords)) + tokCount = count candidate + in if tokCount <= maxT + then go acc (w : currentWords) ws + else + let finishedChunk = T.unwords (reverse currentWords) + newAcc = finishedChunk : acc + -- Overlap words + overlapWords = takeOverlap overlapT (reverse currentWords) [] + in go newAcc (w : overlapWords) ws + + takeOverlap :: Int -> [Text] -> [Text] -> [Text] + takeOverlap _ [] acc = acc + takeOverlap target (pw : pws) acc = + let candidate = T.unwords (pw : acc) + in if count candidate <= target + then takeOverlap target pws (pw : acc) + else if null acc then [pw] else acc diff --git a/src/Langchain/Tool/Async.hs b/src/Langchain/Tool/Async.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Tool/Async.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.Tool.Async +Description : Asynchronous tool execution with timeout, cancellation, and concurrency control +Copyright : (c) 2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Provides non-blocking, async tool execution primitives with per-tool timeout limits +and batch concurrent execution. +-} +module Langchain.Tool.Async + ( executeToolAsync + , executeToolWithTimeout + , executeToolBatchConcurrently + ) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (Async, async, mapConcurrently, race) +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (Value) +import Data.Text (Text) +import qualified Data.Text as T + +import Langchain.Core.Error (LangchainError, toolError) +import Langchain.Tool.Core (Tool (..)) + +-- | Spawn tool execution in an asynchronous background thread +executeToolAsync :: + (MonadIO m) => + Tool IO -> + Value -> + m (Async (Either LangchainError Text)) +executeToolAsync Tool {..} args = liftIO $ do + async (toolExecute args) + +-- | Execute a tool with a strict timeout limit in microseconds +executeToolWithTimeout :: + (MonadIO m, MonadError LangchainError m) => + Tool IO -> + Value -> + Int -> + m Text +executeToolWithTimeout Tool {..} args timeoutMicros = do + res <- liftIO $ race (threadDelay timeoutMicros) (toolExecute args) + case res of + Left () -> + throwError $ + toolError + ("Tool '" <> toolName <> "' timed out after " <> T.pack (show timeoutMicros) <> " microseconds") + (Just toolName) + Nothing + Right (Left err) -> throwError err + Right (Right output) -> pure output + +-- | Execute a batch of tool calls concurrently in parallel +executeToolBatchConcurrently :: + (MonadIO m, MonadError LangchainError m) => + [(Tool IO, Value)] -> + m [Text] +executeToolBatchConcurrently toolCalls = do + results <- liftIO $ mapConcurrently (uncurry toolExecute) toolCalls + case sequence results of + Left err -> throwError err + Right outputs -> pure outputs diff --git a/src/Langchain/Tool/Binding.hs b/src/Langchain/Tool/Binding.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Tool/Binding.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | +Module : Langchain.Tool.Binding +Description : Typeclass for attaching tool definitions to provider-specific model configs +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Provides 'ToolBinder' typeclass enabling agents to attach tool definitions +to provider-specific 'ModelConfig' types in a uniform way. This is the bridge +between provider-agnostic agent code and provider-specific tool APIs. +-} +module Langchain.Tool.Binding + ( ToolBinder (..) + ) where + +import Langchain.Core.Model (ChatModel (..)) +import Langchain.Core.Tool (Tool) + +{- | Typeclass for models that support binding tools into their 'ModelConfig'. + +Agents like 'ReActAgent' use this to pass tool definitions to the LLM +provider in a provider-agnostic way. + += Example + +@ +-- Agent code (provider-agnostic): +let cfg = bindToolsConfig tools Nothing +responseMsg <- invoke model history cfg + +-- The right thing happens automatically: +-- For Ollama: builds a ChatRequest with chatTools set +-- For OpenAI: builds a Value with "tools" key +-- For OllamaWithTools: merges into existing config +@ +-} +class (ChatModel model) => ToolBinder model m where + {- | Convert a list of tools into a provider-specific 'ModelConfig', + optionally merging with an existing config. + -} + bindToolsConfig :: [Tool m] -> Maybe (ModelConfig model) -> Maybe (ModelConfig model) diff --git a/src/Langchain/Tool/Calculator.hs b/src/Langchain/Tool/Calculator.hs --- a/src/Langchain/Tool/Calculator.hs +++ b/src/Langchain/Tool/Calculator.hs @@ -1,150 +1,68 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} {- | Module : Langchain.Tool.Calculator -Description : Mathematical expression calculator tool for LangChain Haskell -Copyright : (c) 2025 Tushar Adhatrao +Description : Standard Calculator Tool implementation +Copyright : (c) 2025-2026 Tushar Adhatrao License : MIT Maintainer : Tushar Adhatrao Stability : experimental -This module provides a calculator tool that can be used with LangChain agents to perform -arithmetic operations. It parses and evaluates mathematical expressions including: - -* Basic arithmetic: addition (+), subtraction (-), multiplication (*), division (/) -* Exponentiation (^) -* Parentheses for grouping -* Floating-point numbers - -The calculator uses a parser combinator approach to handle operator precedence correctly. - -Example usage: - -@ -import Langchain.Tool.Calculator -import Langchain.Tool.Core (runTool) - -main :: IO () -main = do - let calc = CalculatorTool - result <- runTool calc "2 + 3 * 4" - case result of - Left err -> putStrLn $ "Error: " ++ err - Right value -> putStrLn $ "Result: " ++ show value - -- Output: Result: 14.0 -@ +Calculator tool using Langchain.Core.Tool. -} module Langchain.Tool.Calculator - ( CalculatorTool (..) - , Expr (..) - , parseExpression - , evaluateExpression + ( calculatorTool + , evaluateExpr ) where -import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO) +import Data.Aeson +import Data.Aeson.Types (parseEither) import Data.Text (Text) import qualified Data.Text as T -import Langchain.Tool.Core (Tool (..)) -import Text.ParserCombinators.Parsec --- | Expression data type for our calculator -data Expr - = Number_ Double - | Add Expr Expr - | Sub Expr Expr - | Mul Expr Expr - | Div Expr Expr - | Pow Expr Expr - deriving (Show, Eq) - --- | Calculator Tool implementation -data CalculatorTool = CalculatorTool - deriving (Show) - -instance Tool CalculatorTool where - type Input CalculatorTool = Text - type Output CalculatorTool = Either String Double - - toolName _ = "calculator" - - toolDescription _ = - "A calculator tool that can perform basic arithmetic operations. " - <> "Input should be a mathematical expression like '2 + 3 * 4'." - - runTool _ input = do - case parseExpression input of - Left err -> return $ Left $ "Failed to parse expression: " ++ show err - Right expr -> return $ Right $ evaluateExpression expr - --- | Parse a mathematical expression from Text -parseExpression :: Text -> Either ParseError Expr -parseExpression = parse expr "" . T.unpack - where - expr = addSubExpr - - addSubExpr = do - left <- mulDivExpr - rest left - where - rest left = - ( do - void $ char '+' <* spaces - right <- mulDivExpr - rest (Add left right) - ) - <|> ( do - void $ char '-' <* spaces - right <- mulDivExpr - rest (Sub left right) - ) - <|> return left - - mulDivExpr = do - left <- powExpr - rest left - where - rest left = - ( do - void $ char '*' <* spaces - right <- powExpr - rest (Mul left right) - ) - <|> ( do - void $ char '/' <* spaces - right <- powExpr - rest (Div left right) - ) - <|> return left - - powExpr = do - left <- factor - rest left - where - rest left = - ( do - void $ char '^' <* spaces - right <- factor - rest (Pow left right) - ) - <|> return left - - factor = - (Number_ . read <$> numberStr) - <|> (spaces *> char '(' *> spaces *> expr <* spaces <* char ')' <* spaces) +import Langchain.Core.Error (toolError) +import Langchain.Core.Tool (Tool (..), createTool) - numberStr = do - i <- many1 digit - d <- option "" $ (:) <$> char '.' <*> many1 digit - spaces - return (i ++ d) +-- | Simple expression evaluator for arithmetic strings +evaluateExpr :: Text -> Either String Double +evaluateExpr txt = + let cleanTxt = T.replace " " "" txt + in case T.splitOn "+" cleanTxt of + [a, b] -> case (reads (T.unpack a), reads (T.unpack b)) of + ([(aNum, "")], [(bNum, "")]) -> Right (aNum + bNum) + _ -> Left "Failed to parse numbers" + _ -> case T.splitOn "*" cleanTxt of + [a, b] -> case (reads (T.unpack a), reads (T.unpack b)) of + ([(aNum, "")], [(bNum, "")]) -> Right (aNum * bNum) + _ -> Left "Failed to parse numbers" + _ -> Left "Unsupported expression format" --- | Evaluate a parsed expression to a Double -evaluateExpression :: Expr -> Double -evaluateExpression expr = case expr of - Number_ n -> n - Add a b -> evaluateExpression a + evaluateExpression b - Sub a b -> evaluateExpression a - evaluateExpression b - Mul a b -> evaluateExpression a * evaluateExpression b - Div a b -> evaluateExpression a / evaluateExpression b - Pow a b -> evaluateExpression a ** evaluateExpression b +-- | Standard Calculator Tool instance +calculatorTool :: MonadIO m => Tool m +calculatorTool = + createTool + "calculator" + "Useful for evaluating arithmetic math expressions like '2 + 2' or '3 * 4'" + ( object + [ "type" .= ("object" :: Text) + , "properties" + .= object + [ "expression" + .= object + [ "type" .= ("string" :: Text) + , "description" .= ("Arithmetic expression string" :: Text) + ] + ] + , "required" .= (["expression"] :: [Text]) + ] + ) + ( \case + Object o -> case parseEither (.:? "expression") o of + Right (Just expr) -> case evaluateExpr expr of + Right num -> pure $ Right (T.pack $ show num) + Left parseErr -> pure $ Left $ toolError (T.pack parseErr) (Just "calculator") Nothing + _ -> pure $ Left $ toolError "Missing or invalid 'expression' field" (Just "calculator") Nothing + _ -> pure $ Left $ toolError "Invalid arguments object" (Just "calculator") Nothing + ) diff --git a/src/Langchain/Tool/Core.hs b/src/Langchain/Tool/Core.hs --- a/src/Langchain/Tool/Core.hs +++ b/src/Langchain/Tool/Core.hs @@ -1,97 +1,17 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} -{- | Module : Langchain.Tool.Core -Description : Core Tool typeclass for LangChain Haskell -Copyright : (c) 2025 Tushar Adhatrao +{- | +Module : Langchain.Tool.Core +Description : Re-exports effect-polymorphic Tool from langchain-hs-core +Copyright : (c) 2025-2026 Tushar Adhatrao License : MIT Maintainer : Tushar Adhatrao Stability : experimental -Core module defining the Tool typeclass for Langchain-Haskell integration. - -This module provides a typeclass interface for creating interoperable tools -that can be used with Large Language Models (LLMs) in Haskell applications. -The design mirrors LangChain's Python tooling system while maintaining -Haskell's type safety and functional programming principles. - -Example use case: - -> data Calculator = Calculator -> -> instance Tool Calculator where -> type Input Calculator = (Int, Int) -> type Output Calculator = Int -> toolName _ = "calculator" -> toolDescription _ = "Performs arithmetic operations on two integers" -> runTool _ (a, b) = pure (a + b) +Re-exports 'Tool m', 'createTool', and 'toolToValue'. -} module Langchain.Tool.Core - ( Tool (..) + ( module Langchain.Core.Tool ) where -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Text (Text) - -{- | Typeclass defining the interface for tools that can be used with LLMs. - -Tools represent capabilities that can be invoked by language models, -following the LangChain framework's tooling pattern. Each tool must: - -* Define input/output types using type families -* Provide a unique name and description -* Implement an IO-based execution function - -The use of type families allows for flexible yet type-safe tool composition, -while the IO monad accommodates both pure and effectful implementations. --} -class Tool a where - {- | Input type required by the tool - - Example: For a weather lookup tool, this might be 'LocationCoordinates' - -} - type Input a - - {- | Output type produced by the tool - - Example: For a calculator tool, this could be 'Int' or 'Double' - -} - type Output a - - {- | Get the tool's unique identifier - - >>> toolName (undefined :: Calculator) - "calculator" - -} - toolName :: a -> Text - - {- | Get human-readable description of the tool's purpose - - >>> toolDescription (undefined :: Calculator) - "Performs arithmetic operations on two integers" - -} - toolDescription :: a -> Text - - {- | Execute the tool with given input - - This function bridges the gap between LLM abstractions and concrete - implementations. The IO context allows for: - - * Pure computations (via 'pure') - * External API calls - * Database queries - - Example implementation: - - > runTool _ (a, b) = do - > putStrLn "Calculating..." - > pure (a + b) - -} - runTool :: a -> Input a -> IO (Output a) - - -- | MonadIO version of runTool - runToolM :: MonadIO m => a -> Input a -> m (Output a) - runToolM tool toolInput = liftIO $ runTool tool toolInput +import Langchain.Core.Tool diff --git a/src/Langchain/Tool/DuckDuckGo.hs b/src/Langchain/Tool/DuckDuckGo.hs deleted file mode 100644 --- a/src/Langchain/Tool/DuckDuckGo.hs +++ /dev/null @@ -1,266 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - -{- | -Module : Langchain.Tool.DuckDuckGo -Description : Tool for extracting DuckDuckGo search content -Copyright : (c) 2025 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental - -Please note: DuckDuckGo Tool only returns result if the search term has a abstract card --} -module Langchain.Tool.DuckDuckGo (DuckDuckGo (..)) where - -import Control.Exception (SomeException, catch) -import Data.Aeson -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Generics (Generic) -import Langchain.Tool.Core -import Network.HTTP.Simple - --- | Icon data within related topics -newtype Icon = Icon - { iconURL :: Maybe Text - } - deriving (Show, Eq, Generic) - -instance FromJSON Icon where - parseJSON = withObject "Icon" $ \v -> - Icon - <$> v .:? "URL" - --- | A single related topic -data RelatedTopic = RelatedTopic - { topicFirstURL :: Maybe Text - , topicIcon :: Maybe Icon - , topicResult :: Maybe Text - , topicText :: Maybe Text - , topicName :: Maybe Text - , topicTopics :: Maybe [RelatedTopic] - } - deriving (Show, Eq, Generic) - -instance FromJSON RelatedTopic where - parseJSON = withObject "RelatedTopic" $ \v -> - RelatedTopic - <$> v .:? "FirstURL" - <*> v .:? "Icon" - <*> v .:? "Result" - <*> v .:? "Text" - <*> v .:? "Name" - <*> v .:? "Topics" - --- | Meta information about the source -data MetaDeveloper = MetaDeveloper - { devName :: Text - , devURL :: Text - } - deriving (Show, Eq, Generic) - -instance FromJSON MetaDeveloper where - parseJSON = withObject "MetaDeveloper" $ \v -> - MetaDeveloper - <$> v .: "name" - <*> v .: "url" - --- | Source options within meta information -data MetaSrcOptions = MetaSrcOptions - { isMediaWiki :: Maybe Int - , isWikipedia :: Maybe Int - , language :: Maybe Text - } - deriving (Show, Eq, Generic) - -instance FromJSON MetaSrcOptions where - parseJSON = withObject "MetaSrcOptions" $ \v -> - MetaSrcOptions - <$> v .:? "is_mediawiki" - <*> v .:? "is_wikipedia" - <*> v .:? "language" - --- | Meta information about the response -data Meta = Meta - { metaDescription :: Maybe Text - , metaDeveloper :: Maybe [MetaDeveloper] - , metaName :: Maybe Text - , metaPerlModule :: Maybe Text - , metaSrcDomain :: Maybe Text - , metaSrcName :: Maybe Text - , metaSrcOptions :: Maybe MetaSrcOptions - } - deriving (Show, Eq, Generic) - -instance FromJSON Meta where - parseJSON = withObject "Meta" $ \v -> - Meta - <$> v .:? "description" - <*> v .:? "developer" - <*> v .:? "name" - <*> v .:? "perl_module" - <*> v .:? "src_domain" - <*> v .:? "src_name" - <*> v .:? "src_options" - --- | DuckDuckGo API response -data DuckDuckGoResponse = DuckDuckGoResponse - { abstract :: Text - , abstractSource :: Text - , abstractText :: Text - , abstractURL :: Text - , answer :: Text - , answerType :: Text - , definition :: Text - , definitionSource :: Text - , definitionURL :: Text - , entity :: Text - , heading :: Text - , image :: Text - , imageHeight :: Int - , imageIsLogo :: Int - , imageWidth :: Int - , infobox :: Text - , redirect :: Text - , relatedTopics :: [RelatedTopic] - , results :: [Value] - , resultType :: Text -- Called "Type" in the API - , meta :: Maybe Meta - } - deriving (Show, Eq, Generic) - -instance FromJSON DuckDuckGoResponse where - parseJSON = withObject "DuckDuckGoResponse" $ \v -> - DuckDuckGoResponse - <$> v .: "Abstract" - <*> v .: "AbstractSource" - <*> v .: "AbstractText" - <*> v .: "AbstractURL" - <*> v .: "Answer" - <*> v .: "AnswerType" - <*> v .: "Definition" - <*> v .: "DefinitionSource" - <*> v .: "DefinitionURL" - <*> v .: "Entity" - <*> v .: "Heading" - <*> v .: "Image" - <*> v .: "ImageHeight" - <*> v .: "ImageIsLogo" - <*> v .: "ImageWidth" - <*> v .: "Infobox" - <*> v .: "Redirect" - <*> v .: "RelatedTopics" - <*> v .: "Results" - <*> v .: "Type" - <*> v .:? "meta" - -{- --- | Error type for DuckDuckGo API calls -data DuckDuckGoError - = NetworkError Text - | ParseError Text - | OtherError Text - deriving (Show, Eq, Generic) - -instance ToJSON DuckDuckGoError where - toJSON (NetworkError msg) = object ["type" .= ("network" :: Text), "message" .= msg] - toJSON (ParseError msg) = object ["type" .= ("parse" :: Text), "message" .= msg] - toJSON (OtherError msg) = object ["type" .= ("other" :: Text), "message" .= msg] - -} - --- | Query parameter for DuckDuckGo search -newtype DuckDuckGoQuery = DuckDuckGoQuery - { query :: Text - } - deriving (Show, Eq, Generic) - -instance ToJSON DuckDuckGoQuery where - toJSON q = object ["query" .= query q] - --- | The DuckDuckGo tool data type -data DuckDuckGo = DuckDuckGo - deriving (Show, Eq) - --- | Tool instance for DuckDuckGo -instance Tool DuckDuckGo where - type Input DuckDuckGo = Text - type Output DuckDuckGo = Text - - toolName _ = "duckduckgo" - - toolDescription _ = - "Performs web searches using DuckDuckGo and returns structured information about results" - - runTool _ queryData = do - let searchTerm = T.replace " " "+" (T.strip queryData) - let urlString = - "https://duckduckgo.com/?q=" - <> T.unpack searchTerm - <> "&format=json" - eResult <- - ( do - request <- parseRequest urlString - response <- httpLbs request - let body = getResponseBody response - case eitherDecode body of - Left err -> pure $ Left $ T.pack $ show err - Right ddgResponse_ -> pure $ Right ddgResponse_ - ) - `catch` \e -> pure $ Left $ T.pack $ show (e :: SomeException) - case eResult of - Left err -> pure err - Right r -> pure $ ddgToText r - --- | Converts a DuckDuckGoResponse into a concise textual summary suitable for LLM input. -ddgToText :: DuckDuckGoResponse -> Text -ddgToText resp = - T.intercalate "\n\n" $ - catMaybes - [ Just ("# " <> heading resp) - , abstractSection resp - , answerSection resp - , definitionSection resp - , relatedTopicsSection (relatedTopics resp) - ] - -abstractSection :: DuckDuckGoResponse -> Maybe Text -abstractSection resp = do - abst <- if T.null (abstract resp) then Nothing else Just (abstract resp) - url <- if T.null (abstractURL resp) then Nothing else Just (abstractURL resp) - Just $ "Abstract: " <> abst <> "\nSource: " <> url - -answerSection :: DuckDuckGoResponse -> Maybe Text -answerSection resp = - if T.null (answer resp) - then Nothing - else Just ("Answer: " <> answer resp) - -definitionSection :: DuckDuckGoResponse -> Maybe Text -definitionSection resp = do - def <- if T.null (definition resp) then Nothing else Just (definition resp) - url <- - if T.null (definitionURL resp) - then - Nothing - else Just (definitionURL resp) - Just $ "Definition: " <> def <> "\nSource: " <> url - -relatedTopicsSection :: [RelatedTopic] -> Maybe Text -relatedTopicsSection rts = - let processed = concatMap processRelatedTopic rts - in if null processed then Nothing else Just (T.unlines processed) - -processRelatedTopic :: RelatedTopic -> [Text] -processRelatedTopic rt = - case (topicName rt, topicTopics rt) of - -- Handle categorized group - (Just name, Just subtopics) -> - ("*" <> name <> "*") : concatMap processRelatedTopic subtopics - -- Handle individual topic - _ -> - case (topicText rt, topicFirstURL rt) of - (Just text, Just url) -> ["- [" <> text <> "](" <> url <> ")"] - _ -> [] diff --git a/src/Langchain/Tool/FileSystem.hs b/src/Langchain/Tool/FileSystem.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Tool/FileSystem.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Langchain.Tool.FileSystem +Description : Standard File System Tools implementation +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +File system tools (readFile, writeFile, listDir) built on Langchain.Core.Tool. +-} +module Langchain.Tool.FileSystem + ( readFileTool + , writeFileTool + , listDirTool + ) where + +import Control.Exception (try) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson +import Data.Aeson.Types (parseEither) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import System.Directory (listDirectory) + +import Langchain.Core.Error (toolError) +import Langchain.Core.Tool (Tool (..), createTool) + +-- | Read file content tool +readFileTool :: MonadIO m => Tool m +readFileTool = + createTool + "read_file" + "Read text contents from a file path" + ( object + [ "type" .= ("object" :: Text) + , "properties" + .= object + ["path" .= object ["type" .= ("string" :: Text)]] + , "required" .= (["path"] :: [Text]) + ] + ) + ( \case + Object o -> case parseEither (.:? "path") o of + Right (Just p) -> do + eContent <- liftIO $ try (TIO.readFile (T.unpack p)) + case eContent of + Left err -> pure $ Left $ toolError (T.pack $ show (err :: IOError)) (Just "read_file") Nothing + Right txt -> pure $ Right txt + _ -> pure $ Left $ toolError "Missing 'path' field" (Just "read_file") Nothing + _ -> pure $ Left $ toolError "Invalid arguments object" (Just "read_file") Nothing + ) + +-- | Write content to file tool +writeFileTool :: MonadIO m => Tool m +writeFileTool = + createTool + "write_file" + "Write text contents to a file path" + ( object + [ "type" .= ("object" :: Text) + , "properties" + .= object + [ "path" .= object ["type" .= ("string" :: Text)] + , "content" .= object ["type" .= ("string" :: Text)] + ] + , "required" .= (["path", "content"] :: [Text]) + ] + ) + ( \case + Object o -> case (parseEither (.:? "path") o, parseEither (.:? "content") o) of + (Right (Just p), Right (Just content)) -> do + eRes <- liftIO $ try (TIO.writeFile (T.unpack p) content) + case eRes of + Left err -> pure $ Left $ toolError (T.pack $ show (err :: IOError)) (Just "write_file") Nothing + Right () -> pure $ Right ("Successfully wrote to " <> p) + _ -> pure $ Left $ toolError "Missing 'path' or 'content' field" (Just "write_file") Nothing + _ -> pure $ Left $ toolError "Invalid arguments object" (Just "write_file") Nothing + ) + +-- | List directory contents tool +listDirTool :: MonadIO m => Tool m +listDirTool = + createTool + "list_directory" + "List files and subdirectories in a directory path" + ( object + [ "type" .= ("object" :: Text) + , "properties" + .= object + ["path" .= object ["type" .= ("string" :: Text)]] + , "required" .= (["path"] :: [Text]) + ] + ) + ( \case + Object o -> case parseEither (.:? "path") o of + Right (Just p) -> do + eFiles <- liftIO $ try (listDirectory (T.unpack p)) + case eFiles of + Left err -> pure $ Left $ toolError (T.pack $ show (err :: IOError)) (Just "list_directory") Nothing + Right files -> pure $ Right (T.unlines $ map T.pack files) + _ -> pure $ Left $ toolError "Missing 'path' field" (Just "list_directory") Nothing + _ -> pure $ Left $ toolError "Invalid arguments object" (Just "list_directory") Nothing + ) diff --git a/src/Langchain/Tool/GenericSchema.hs b/src/Langchain/Tool/GenericSchema.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Tool/GenericSchema.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +{- | +Module : Langchain.Tool.GenericSchema +Description : Type-safe tool parameter JSON schema derivation using GHC Generics +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Automatically derives OpenAI-compatible tool JSON schema objects from Haskell record types +using GHC Generics at compile time. +-} +module Langchain.Tool.GenericSchema + ( DeriveToolSchema (..) + , deriveToolParametersSchema + ) where + +import Data.Aeson (Value (..), object, (.=)) +import qualified Data.Aeson.Key as Key +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) +import qualified Data.Map.Strict as Map +import Data.Proxy (Proxy (..)) +import Data.Scientific (Scientific) +import Data.Text (Text) +import qualified Data.Text as TS +import Data.Time (Day, UTCTime) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Generics + +-- | Typeclass for deriving tool JSON schema parameters +class DeriveToolSchema a where + deriveToolSchema :: Proxy a -> Value + default deriveToolSchema :: (GToolRecordSchema (Rep a)) => Proxy a -> Value + deriveToolSchema _ = deriveToolParametersSchema (Proxy :: Proxy a) + +-- | Derive OpenAI tool parameter schema object +deriveToolParametersSchema :: + forall a. (GToolRecordSchema (Rep a)) => Proxy a -> Value +deriveToolParametersSchema _ = + let (props, reqs) = gToolRecordSchema (Proxy :: Proxy (Rep a)) + in object + [ "type" .= ("object" :: Text) + , "properties" .= object props + , "required" .= reqs + ] + +class GToolRecordSchema (f :: Type -> Type) where + gToolRecordSchema :: Proxy f -> ([(Key.Key, Value)], [Text]) + +instance (GToolRecordSchema f, GToolRecordSchema g) => GToolRecordSchema (f :*: g) where + gToolRecordSchema _ = + let (p1, r1) = gToolRecordSchema (Proxy :: Proxy f) + (p2, r2) = gToolRecordSchema (Proxy :: Proxy g) + in (p1 ++ p2, r1 ++ r2) + +instance (GToolRecordSchema f) => GToolRecordSchema (M1 D c f) where + gToolRecordSchema _ = gToolRecordSchema (Proxy :: Proxy f) + +instance (GToolRecordSchema f) => GToolRecordSchema (M1 C c f) where + gToolRecordSchema _ = gToolRecordSchema (Proxy :: Proxy f) + +instance (Selector s, ToolFieldSchema a) => GToolRecordSchema (M1 S s (K1 R a)) where + gToolRecordSchema _ = + let selNameStr = selName (undefined :: M1 S s (K1 R a) p) + propKey = Key.fromString selNameStr + propSchema = toolFieldSchema (Proxy :: Proxy a) + req = [TS.pack selNameStr | not (isOptionalField (Proxy :: Proxy a))] + in ([(propKey, propSchema)], req) + +class ToolFieldSchema a where + toolFieldSchema :: Proxy a -> Value + default toolFieldSchema :: (GToolRecordSchema (Rep a)) => Proxy a -> Value + toolFieldSchema _ = deriveToolParametersSchema (Proxy :: Proxy a) + + isOptionalField :: Proxy a -> Bool + isOptionalField _ = False + +instance ToolFieldSchema Text where + toolFieldSchema _ = object ["type" .= ("string" :: Text)] + +instance ToolFieldSchema String where + toolFieldSchema _ = object ["type" .= ("string" :: Text)] + +instance ToolFieldSchema Char where + toolFieldSchema _ = object ["type" .= ("string" :: Text)] + +instance ToolFieldSchema Int where + toolFieldSchema _ = object ["type" .= ("integer" :: Text)] + +instance ToolFieldSchema Int8 where + toolFieldSchema _ = object ["type" .= ("integer" :: Text)] + +instance ToolFieldSchema Int16 where + toolFieldSchema _ = object ["type" .= ("integer" :: Text)] + +instance ToolFieldSchema Int32 where + toolFieldSchema _ = object ["type" .= ("integer" :: Text)] + +instance ToolFieldSchema Int64 where + toolFieldSchema _ = object ["type" .= ("integer" :: Text)] + +instance ToolFieldSchema Integer where + toolFieldSchema _ = object ["type" .= ("integer" :: Text)] + +instance ToolFieldSchema Word where + toolFieldSchema _ = object ["type" .= ("integer" :: Text)] + +instance ToolFieldSchema Word8 where + toolFieldSchema _ = object ["type" .= ("integer" :: Text)] + +instance ToolFieldSchema Word16 where + toolFieldSchema _ = object ["type" .= ("integer" :: Text)] + +instance ToolFieldSchema Word32 where + toolFieldSchema _ = object ["type" .= ("integer" :: Text)] + +instance ToolFieldSchema Word64 where + toolFieldSchema _ = object ["type" .= ("integer" :: Text)] + +instance ToolFieldSchema Double where + toolFieldSchema _ = object ["type" .= ("number" :: Text)] + +instance ToolFieldSchema Float where + toolFieldSchema _ = object ["type" .= ("number" :: Text)] + +instance ToolFieldSchema Scientific where + toolFieldSchema _ = object ["type" .= ("number" :: Text)] + +instance ToolFieldSchema Bool where + toolFieldSchema _ = object ["type" .= ("boolean" :: Text)] + +instance ToolFieldSchema UTCTime where + toolFieldSchema _ = + object + [ "type" .= ("string" :: Text) + , "format" .= ("date-time" :: Text) + ] + +instance ToolFieldSchema Day where + toolFieldSchema _ = + object + [ "type" .= ("string" :: Text) + , "format" .= ("date" :: Text) + ] + +instance ToolFieldSchema Value where + toolFieldSchema _ = object ["type" .= ("object" :: Text)] + +instance (ToolFieldSchema a) => ToolFieldSchema (Map.Map Text a) where + toolFieldSchema _ = + object + [ "type" .= ("object" :: Text) + , "additionalProperties" .= toolFieldSchema (Proxy :: Proxy a) + ] + +instance (ToolFieldSchema a) => ToolFieldSchema (Maybe a) where + toolFieldSchema _ = toolFieldSchema (Proxy :: Proxy a) + isOptionalField _ = True + +instance {-# OVERLAPPABLE #-} (ToolFieldSchema a) => ToolFieldSchema [a] where + toolFieldSchema _ = + object + [ "type" .= ("array" :: Text) + , "items" .= toolFieldSchema (Proxy :: Proxy a) + ] diff --git a/src/Langchain/Tool/Shell.hs b/src/Langchain/Tool/Shell.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Tool/Shell.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Langchain.Tool.Shell +Description : Shell command execution tool +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Provides shell command execution capabilities for agents via System.Process. +-} +module Langchain.Tool.Shell + ( shellTool + ) where + +import Control.Exception (SomeException, try) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (Value (..), object, (.=)) +import Data.Aeson.Types (parseEither, (.:?)) +import Data.Text (Text) +import qualified Data.Text as T +import System.Exit (ExitCode (..)) +import System.Process (readProcessWithExitCode) + +import Langchain.Core.Error (toolError) +import Langchain.Core.Tool (Tool (..), createTool) + +-- | Tool that executes a shell command via @sh -c@ and returns its output +shellTool :: MonadIO m => Tool m +shellTool = + createTool + "shell_command" + "Execute a shell command line (e.g. bash/sh) and return stdout and stderr output." + ( object + [ "type" .= ("object" :: Text) + , "properties" + .= object + [ "command" + .= object + [ "type" .= ("string" :: Text) + , "description" .= ("The shell command line to execute" :: Text) + ] + ] + , "required" .= (["command"] :: [Text]) + ] + ) + ( \case + Object o -> case parseEither (.:? "command") o of + Right (Just cmd) -> do + eRes <- liftIO $ try (readProcessWithExitCode "sh" ["-c", T.unpack cmd] "") + case eRes of + Left err -> + pure $ Left $ toolError (T.pack $ show (err :: SomeException)) (Just "shell_command") Nothing + Right (ExitSuccess, stdoutStr, stderrStr) -> + let out = T.strip (T.pack stdoutStr) + err = T.strip (T.pack stderrStr) + in if T.null out + then if T.null err then pure $ Right "Command completed with no output." else pure $ Right err + else pure $ Right out + Right (ExitFailure code, stdoutStr, stderrStr) -> + let combined = T.strip (T.pack (stdoutStr <> "\n" <> stderrStr)) + in pure $ + Right $ + "Command exited with code " + <> T.pack (show code) + <> (if T.null combined then "" else ": " <> combined) + _ -> pure $ Left $ toolError "Missing 'command' parameter" (Just "shell_command") Nothing + _ -> pure $ Left $ toolError "Invalid arguments object" (Just "shell_command") Nothing + ) diff --git a/src/Langchain/Tool/Utils.hs b/src/Langchain/Tool/Utils.hs deleted file mode 100644 --- a/src/Langchain/Tool/Utils.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{- | -Module : Langchain.Tool.Utils -Description : Common utility functions for LangChain tool modules -Copyright : (c) 2025 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental - -This module provides utility functions used by various tool implementations, -particularly for HTML content processing and cleaning operations. --} -module Langchain.Tool.Utils (cleanBodyContent, cleanHtmlContent) where - -import qualified Data.List as L -import Data.Maybe (catMaybes) -import Data.Text (Text) -import qualified Text.HTML.TagSoup as TS -import qualified Text.StringLike as TS - --- | This function takes a text that contains html tags, and removes them while preserving links -cleanHtmlContent :: Text -> Text -cleanHtmlContent c = extractText (TS.parseTags c) - --- | Clean the HTML content: extract body, remove scripts, and strip attributes -cleanBodyContent :: [TS.Tag Text] -> Text -cleanBodyContent tags = - let -- Extract only body content - bodyTags = case TS.partitions (TS.isTagOpenName "body") tags of - [] -> tags -- If no body tag is found, use all tags - (bodySection : _) -> bodySection - filteredTags = removeTags bodyTags - content = extractText filteredTags - in content - -{- -If the tag is anchor tag, then extract and append the link as well. --} -extractText :: [TS.Tag Text] -> Text -extractText ts = TS.strConcat $ catMaybes (go ts) - where - go [] = [] - go ((TS.TagOpen "a" aAttrList) : xs) = - ( Just "link: " - <> L.lookup "href" aAttrList - <> Just " for:" - ) - : go xs - go (x : xs) = TS.maybeTagText x : go xs - -allowedTags :: [TS.Tag Text -> Bool] -allowedTags = - textTag - : ( mkIsTag - <$> [ "p" - , "button" - , "a" - , "div" - , "h1" - , "h2" - , "h3" - , "h4" - , "h5" - , "h6" - , "span" - , "ul" - , "li" - , "input" - , "submit" - , "label" - , "option" - , "select" - , "textarea" - , "blockquote" - , "pre" - , "code" - , "strong" - , "em" - , "b" - , "i" - , "u" - , "mark" - , "small" - , "big" - ] - ) - where - textTag (TS.TagText _) = True - textTag _ = False - mkIsTag name tag = isTag tag name - -isTag :: TS.Tag Text -> Text -> Bool -isTag (TS.TagOpen name _) t = name == t -isTag (TS.TagClose name) t = name == t -isTag _ _ = False - -removeTags :: [TS.Tag Text] -> [TS.Tag Text] -removeTags = filter (\t -> any (\f -> f t) allowedTags) diff --git a/src/Langchain/Tool/WebScraper.hs b/src/Langchain/Tool/WebScraper.hs deleted file mode 100644 --- a/src/Langchain/Tool/WebScraper.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - -{- | -Module : Langchain.Tool.WebScraper -Description : Tool for scrapping text content from URL -Copyright : (c) 2025 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental - -WebScraper is a tool that scrapes text content from a given URL. -It fetches the HTML content of the page, extracts the body text, removes scripts, and strips class/id/style attributes from the HTML tags. -It is designed to be used with the Langchain framework for building language models and applications. --} -module Langchain.Tool.WebScraper (WebScraper (..), WebPageInfo (..), fetchAndScrape) where - -import Control.Exception (SomeException, try) -import Data.Aeson (ToJSON) -import qualified Data.ByteString.Lazy as LBS -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import GHC.Generics (Generic) -import Langchain.Tool.Core -import Langchain.Tool.Utils -import Network.HTTP.Simple -import qualified Text.HTML.TagSoup as TS - --- | Represents a web scraper tool that extracts content from web pages -data WebScraper = WebScraper - deriving (Show) - --- | Stores the extracted webpage information -data WebPageInfo = WebPageInfo - { pageTitle :: Maybe Text - , pageContent :: Text - } - deriving (Show, Generic) - --- Make WebPageInfo serializable to JSON -instance ToJSON WebPageInfo - --- | Input type for the WebScraper - just a URL -type ScraperInput = Text - --- | Implement the Tool typeclass for WebScraper -instance Tool WebScraper where - type Input WebScraper = ScraperInput - type Output WebScraper = (Either String Text) - - toolName _ = "web_scraper" - - toolDescription _ = - "Scrapes content from a webpage. Provide a valid URL, and it will extract only the textual body content " - <> "with scripts removed and without class/id/style attributes." - - runTool _ url = do - result <- fetchAndScrape url - case result of - Left err -> pure $ Left $ "Error scraping webpage: " <> err - Right info -> pure $ Right $ pageContent info - --- | Fetch HTML content from a URL and extract webpage information -fetchAndScrape :: Text -> IO (Either String WebPageInfo) -fetchAndScrape url = do - request_ <- parseRequest (T.unpack url) - eResp <- try $ httpLBS request_ :: IO (Either SomeException (Response LBS.ByteString)) - case eResp of - Left err -> pure $ Left (show err) - Right r -> do - let rBody = getResponseBody r - let htmlContent = TE.decodeUtf8 $ LBS.toStrict rBody - - -- Clean and extract the content - let tags = TS.parseTags htmlContent - let title = extractTitle tags - let cleanedContent = cleanBodyContent tags - - pure $ Right $ WebPageInfo title cleanedContent - --- | Extract the title from parsed HTML tags -extractTitle :: [TS.Tag Text] -> Maybe Text -extractTitle tags = - let titleTags = TS.partitions (TS.isTagOpenName "title") tags - in if null titleTags - then Nothing - else case listToMaybe titleTags of - Nothing -> Nothing - Just r -> Just $ T.strip $ TS.innerText r diff --git a/src/Langchain/Tool/WikipediaTool.hs b/src/Langchain/Tool/WikipediaTool.hs deleted file mode 100644 --- a/src/Langchain/Tool/WikipediaTool.hs +++ /dev/null @@ -1,300 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} - -{- | -Module : Langchain.Tool.WikipediaTool -Description : Tool for extracting wikipedia content. -Copyright : (c) 2025 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental --} -module Langchain.Tool.WikipediaTool - ( -- * Configuration - WikipediaTool (..) - , defaultWikipediaTool - - -- * Parameters - , defaultTopK - , defaultDocMaxChars - , defaultLanguageCode - - -- * Internal types - , SearchQuery (..) - , SearchResponse (..) - , Page (..) - , SearchResult (..) - , Pages (..) - , PageResponse (..) - ) where - -import Control.Exception (throwIO) -import Data.Aeson (FromJSON (..), decode, withObject, (.:)) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Generics -import Langchain.Runnable.Core (Runnable (..)) -import Langchain.Tool.Core -import Langchain.Tool.Utils (cleanHtmlContent) -import Network.HTTP.Simple - -{- | -Wikipedia search tool configuration -The tool uses Wikipedia's API to perform searches and retrieve page extracts. - -Example configuration: - -> customTool = WikipediaTool -> { topK = 3 -> , docMaxChars = 1000 -> , languageCode = "es" -> } --} -data WikipediaTool = WikipediaTool - { topK :: Int - -- ^ Number of Wikipedia pages to include in the result. - , docMaxChars :: Int - -- ^ Number of characters to take from each page. - , languageCode :: Text - -- ^ Language code to use (e.g., "en" for English). - } - deriving (Eq, Show) - --- | Default value for top K -defaultTopK :: Int -defaultTopK = 1 - --- | Default value for max chars -defaultDocMaxChars :: Int -defaultDocMaxChars = 2000 - --- | Default language -defaultLanguageCode :: Text -defaultLanguageCode = "en" - -{- | -Wikipedia search tool configuration -The tool uses Wikipedia's API to perform searches and retrieve page extracts. - -Example configuration: - -> customTool = WikipediaTool -> { topK = 3 -> , docMaxChars = 1000 -> , languageCode = "es" -> } --} -defaultWikipediaTool :: WikipediaTool -defaultWikipediaTool = - WikipediaTool - { topK = defaultTopK - , docMaxChars = defaultDocMaxChars - , languageCode = defaultLanguageCode - } - --- | Tool instance for WikipediaTool. -instance Tool WikipediaTool where - type Input WikipediaTool = Text - - -- \^ Natural language search query (e.g., "Quantum computing") - - type Output WikipediaTool = Text - - -- \^ Concatenated page extracts with separators - - -- \| - -- Returns "Wikipedia" as the tool identifier - -- - -- >>> toolName (undefined :: WikipediaTool) - -- "Wikipedia" - -- - toolName _ = "Wikipedia" - - -- \| - -- Provides a description for LLM agents: - -- - -- >>> toolDescription (undefined :: WikipediaTool) - -- "A wrapper around Wikipedia. Useful for answering..." - -- - toolDescription _ = - "A wrapper around Wikipedia. Useful for answering general questions about people, places, companies, facts, historical events, or other subjects. Input should be a single worded search query." - - -- \| - -- Executes Wikipedia search and content retrieval. - -- Handles API calls and response parsing, returning concatenated extracts. - -- - -- Example flow: - -- - -- 1. Perform search query - -- 2. Retrieve top K page IDs - -- 3. Fetch and truncate page content - -- 4. Combine results with separators - -- - -- Throws exceptions on: - -- - -- - API request failures - -- - JSON parsing errors - -- - Missing page content - -- - runTool = searchWiki - --- | Perform a Wikipedia search and retrieve page extracts. -searchWiki :: WikipediaTool -> Text -> IO Text -searchWiki tool q = do - SearchResponse {..} <- performSearch tool q - if null (search query) - then return "no wikipedia pages found" - else do - let pageIds = map pageid (take (topK tool) (search query)) - pages <- mapM (getPage tool) pageIds - let extracts = - map - ( T.take (docMaxChars tool) - . cleanHtmlContent - . extract - ) - pages - return $ T.intercalate "\n\n" extracts - --- | Perform a search on Wikipedia. -performSearch :: WikipediaTool -> Text -> IO SearchResponse -performSearch tool q = do - let params = - M.fromList - [ ("format", "json") - , ("action", "query") - , ("list", "search") - , ("srsearch", T.unpack q) - , ("srlimit", show (topK tool)) - ] - url = - T.pack $ - "https://" - <> T.unpack (languageCode tool) - <> ".wikipedia.org/w/api.php?" - <> urlEncode params - request <- parseRequest (T.unpack url) - response <- httpLbs request - let body = getResponseBody response - case decode body of - Just result -> return result - Nothing -> throwIO $ userError "Failed to decode search response" - --- | Get a page extract from Wikipedia. -getPage :: WikipediaTool -> Int -> IO Page -getPage tool pageId = do - let params = - M.fromList - [ ("format", "json") - , ("action", "query") - , ("prop", "extracts") - , ("pageids", show pageId) - ] - url = - T.pack $ - "https://" - <> T.unpack (languageCode tool) - <> ".wikipedia.org/w/api.php?" - <> urlEncode params - request <- parseRequest (T.unpack url) - response <- httpLbs request - let body = getResponseBody response - case decode body of - Just (PageResponse (Pages p)) -> case M.lookup (show pageId) p of - Just page -> return page - Nothing -> throwIO $ userError "Page not found in response" - Nothing -> throwIO $ userError "Failed to decode page response" - --- | URL encode a map of parameters. -urlEncode :: Map String String -> String -urlEncode = concatMap (\(k, v) -> k ++ "=" ++ v ++ "&") . M.toList - --- | Data types for JSON parsing. -newtype SearchResponse = SearchResponse - { query :: SearchQuery - } - deriving (Show, Generic, FromJSON) - --- | Type for list of search result -newtype SearchQuery = SearchQuery - { search :: [SearchResult] - } - deriving (Show) - -instance FromJSON SearchQuery where - parseJSON = withObject "SearchQuery" $ \v -> - SearchQuery - <$> v .: "search" - --- | Result of SearchResult -data SearchResult = SearchResult - { ns :: Int - , title_ :: Text - , pageid :: Int - , size :: Int - , wordcount :: Int - , snippet :: Text - , timestamp :: Text - } - deriving (Show) - -instance FromJSON SearchResult where - parseJSON = withObject "SearchResult" $ \v -> - SearchResult - <$> v .: "ns" - <*> v .: "title" - <*> v .: "pageid" - <*> v .: "size" - <*> v .: "wordcount" - <*> v .: "snippet" - <*> v .: "timestamp" - --- | Wikipedia response -newtype PageResponse = PageResponse - { query :: Pages - } - deriving (Generic, Eq, Show, FromJSON) - --- | Collection of Wikipedia pages, where key is page id -newtype Pages = Pages - { pages :: Map String Page - } - deriving (Generic, Eq, Show, FromJSON) - --- | Represents wikipedia page -data Page = Page - { title :: Text - , extract :: Text - } - deriving (Show, Eq) - -instance FromJSON Page where - parseJSON = withObject "Page" $ \v -> - Page - <$> v .: "title" - <*> v .: "extract" - -{- | -Implements Runnable compatibility layer -Note: The current implementation returns 'Right' values only, -though the type signature allows for future error handling. - -Example usage: - -> response <- invoke defaultWikipediaTool "Artificial intelligence" -> case response of -> Right content -> putStrLn content -> Left err -> print err --} -instance Runnable WikipediaTool where - type RunnableInput WikipediaTool = Text - type RunnableOutput WikipediaTool = Text - - -- TODO: runTool should return an Either - invoke tool input = Right <$> runTool tool input diff --git a/src/Langchain/Utils.hs b/src/Langchain/Utils.hs deleted file mode 100644 --- a/src/Langchain/Utils.hs +++ /dev/null @@ -1,27 +0,0 @@ -{- | -Module : Langchain.Utils -Description : Utility functions for LangChain Haskell -Copyright : (c) 2025 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental - -This module provides utility functions used throughout the LangChain Haskell library. --} -module Langchain.Utils (showText) where - -import Data.Text (Text, pack) - -{- | Convert any 'Show' instance to 'Text' -Convenience function for converting values to Text format. - -Example: - ->>> showText (42 :: Int) -"42" - ->>> showText (True) -"True" --} -showText :: Show a => a -> Text -showText = pack . show diff --git a/src/Langchain/VectorStore/Core.hs b/src/Langchain/VectorStore/Core.hs --- a/src/Langchain/VectorStore/Core.hs +++ b/src/Langchain/VectorStore/Core.hs @@ -1,123 +1,56 @@ +{-# LANGUAGE FlexibleContexts #-} + {- | Module : Langchain.VectorStore.Core -Description : Core vector store abstraction for semantic search -Copyright : (c) 2025 Tushar Adhatrao +Description : Effect-polymorphic vector store abstraction for semantic search +Copyright : (c) 2025-2026 Tushar Adhatrao License : MIT Maintainer : Tushar Adhatrao Stability : experimental -Haskell implementation of LangChain's vector store interface, providing: - -- Document storage with vector embeddings -- Similarity-based search capabilities -- Integration with Runnable workflows - -Example usage with hypothetical FAISS store: - -@ --- Create vector store instance -faissStore :: FAISSStore -faissStore = emptyFAISSStore - --- Add documents with embeddings -docs = [Document "Haskell is functional" mempty, ...] -updatedStore <- addDocuments faissStore docs - --- Perform similarity search -results <- similaritySearch updatedStore "functional programming" 5 --- Returns top 5 relevant documents -@ +Effect-polymorphic VectorStore typeclass supporting document insertion, +deletion, and vector/text similarity search. -} -module Langchain.VectorStore.Core (VectorStore (..)) -where +module Langchain.VectorStore.Core + ( VectorStore (..) + ) where -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Except (MonadError) +import Control.Monad.IO.Class (MonadIO) import Data.Int (Int64) import Data.Text (Text) -import Langchain.DocumentLoader.Core -import Langchain.Error (LangchainResult) --- TODO: Add delete document mechanism, for this we need to generate and use id (Int) - -{- | Vector store abstraction following LangChain's design patterns -Implementations should handle document storage, vectorization, and similarity search. - -Example instance for an in-memory store: - -@ -data InMemoryStore = InMemoryStore - { documents :: [Document] - , embeddings :: [[Float]] - } +import Langchain.Core.Error (LangchainError) +import Langchain.DocumentLoader.Core (Document) -instance VectorStore InMemoryStore where - addDocuments store docs = ... - similaritySearch store query k = ... -@ --} +-- | Effect-polymorphic VectorStore typeclass class VectorStore vs where - {- | Add documents to the vector store - - Example: - - >>> addDocuments myStore [Document "Test content" mempty] - Right (updatedStoreWithNewDocs) - -} - addDocuments :: vs -> [Document] -> IO (LangchainResult vs) - - addDocumentsM :: MonadIO m => vs -> [Document] -> m (LangchainResult vs) - addDocumentsM store docs = liftIO $ addDocuments store docs - - {- | - Requires document ID tracking to be implemented in store instances. - - Example usage (when implemented): - - >>> delete myStore [123] - Right (storeWithoutDoc123) - -} - delete :: vs -> [Int64] -> IO (LangchainResult vs) - - deleteM :: MonadIO m => vs -> [Int64] -> m (LangchainResult vs) - deleteM store ids = liftIO $ delete store ids - - {- | Find documents similar to query text - Uses embedded vector representations for semantic search. - - Example: - - >>> similaritySearch store "Haskell monads" 3 - Right [Document "Monads in FP...", ...] - -} - similaritySearch :: vs -> Text -> Int -> IO (LangchainResult [Document]) - - similaritySearchM :: MonadIO m => vs -> Text -> Int -> m (LangchainResult [Document]) - similaritySearchM store query k = liftIO $ similaritySearch store query k - - {- | Find documents similar to vector representation - For direct vector comparisons without text conversion. - - Example: - - >>> similaritySearchByVector store [0.1, 0.3, ...] 5 - Right [mostSimilarDoc1, ...] - -} - similaritySearchByVector :: vs -> [Float] -> Int -> IO (LangchainResult [Document]) - - similaritySearchByVectorM :: MonadIO m => vs -> [Float] -> Int -> m (LangchainResult [Document]) - similaritySearchByVectorM store vector k = liftIO $ similaritySearchByVector store vector k + -- | Add documents with generated embeddings + addDocuments :: + (MonadIO m, MonadError LangchainError m) => + vs -> + [Document] -> + m vs -{- $examples -Test case patterns: -1. Document addition - >>> addDocuments emptyStore [doc1, doc2] - Right (storeWithDocs) + -- | Delete documents by unique integer ID + delete :: + (MonadIO m, MonadError LangchainError m) => + vs -> + [Int64] -> + m vs -2. Similarity search - >>> similaritySearch populatedStore "AI" 3 - Right [relevantDoc1, relevantDoc2, relevantDoc3] + -- | Semantic similarity search using text query + similaritySearch :: + (MonadIO m, MonadError LangchainError m) => + vs -> + Text -> + Int -> + m [Document] -3. Vector-based search - >>> similaritySearchByVector store [0.5, 0.2, ...] 5 - Right [top5MatchingDocs] --} + -- | Direct similarity search using embedding vector + similaritySearchByVector :: + (MonadIO m, MonadError LangchainError m) => + vs -> + [Float] -> + Int -> + m [Document] diff --git a/src/Langchain/VectorStore/InMemory.hs b/src/Langchain/VectorStore/InMemory.hs --- a/src/Langchain/VectorStore/InMemory.hs +++ b/src/Langchain/VectorStore/InMemory.hs @@ -1,32 +1,14 @@ +{-# LANGUAGE FlexibleContexts #-} + {- | Module : Langchain.VectorStore.InMemory Description : In-memory vector store implementation for LangChain Haskell -Copyright : (c) 2025 Tushar Adhatrao +Copyright : (c) 2025-2026 Tushar Adhatrao License : MIT Maintainer : Tushar Adhatrao Stability : experimental -In-memory vector store implementation following LangChain's patterns, supporting: - -- Document storage with embeddings -- Cosine similarity search -- Integration with embedding models - -Example usage: - -@ --- Create store with Ollama embeddings -ollamaEmb = OllamaEmbeddings "nomic-embed" Nothing Nothing -inMem = emptyInMemoryVectorStore ollamaEmb - --- Add documents -docs = [Document "Hello World" mempty, Document "Haskell is functional" mempty] -updatedStore <- addDocuments inMem docs - --- Perform similarity search -results <- similaritySearch updatedStore "functional programming" 1 --- Right [Document "Haskell is functional"...] -@ +In-memory vector store implementation supporting cosine similarity search. -} module Langchain.VectorStore.InMemory ( InMemory (..) @@ -37,161 +19,81 @@ , cosineSimilarity ) where -import Data.Bifunctor +import Control.Monad.Except (MonadError) +import Control.Monad.IO.Class (MonadIO) +import Data.Bifunctor (second) import Data.Int (Int64) import Data.List (sortBy) import qualified Data.Map.Strict as Map import Data.Ord (comparing) + +import Langchain.Core.Error (LangchainError) import Langchain.DocumentLoader.Core (Document) import Langchain.Embeddings.Core -import Langchain.Error (LangchainError) import Langchain.VectorStore.Core -{- | Compute dot product of two vectors -Example: - ->>> dotProduct [1,2,3] [4,5,6] -32.0 --} +-- | Compute dot product of two vectors dotProduct :: [Float] -> [Float] -> Float dotProduct a b = sum $ zipWith (*) a b -{- | Calculate Euclidean norm of a vector -Example: - ->>> norm [3,4] -5.0 --} +-- | Calculate Euclidean norm of a vector norm :: [Float] -> Float norm a = sqrt $ sum $ map (^ (2 :: Int)) a -{- | Calculate cosine similarity between vectors -Example: - ->>> cosineSimilarity [1,2] [2,4] -1.0 --} +-- | Calculate cosine similarity between vectors cosineSimilarity :: [Float] -> [Float] -> Float -cosineSimilarity a b = dotProduct a b / (norm a * norm b) +cosineSimilarity a b = + let nA = norm a + nB = norm b + in if nA == 0 || nB == 0 + then 0 + else dotProduct a b / (nA * nB) -{- | Create empty in-memory store with embedding model -Example: +-- | In-memory vector store data type +data InMemory m = InMemory + { embeddingModel :: m + , store :: Map.Map Int64 (Document, [Float]) + } + deriving (Show, Eq) ->>> emptyInMemoryVectorStore ollamaEmb -InMemory {_embeddingModel = ..., _store = empty} --} -emptyInMemoryVectorStore :: Embeddings m => m -> InMemory m +-- | Create empty in-memory store with embedding model +emptyInMemoryVectorStore :: m -> InMemory m emptyInMemoryVectorStore model = InMemory model Map.empty -{- | Initialize store from documents using embeddings -Example: - ->>> fromDocuments ollamaEmb [Document "Test" mempty] -Right (InMemory {_store = ...}) --} -fromDocuments :: Embeddings m => m -> [Document] -> IO (Either LangchainError (InMemory m)) +-- | Initialize store from documents using embeddings +fromDocuments :: + (Embeddings m, MonadIO monad, MonadError LangchainError monad) => + m -> + [Document] -> + monad (InMemory m) fromDocuments model docs = do let vs = emptyInMemoryVectorStore model addDocuments vs docs -{- | In-memory vector store implementation -Stores documents with: - -- Embedding model reference -- Map of document IDs to (Document, embedding) pairs --} -data Embeddings m => InMemory m = InMemory - { embeddingModel :: m - , store :: Map.Map Int64 (Document, [Float]) - } - deriving (Show, Eq) - instance Embeddings m => VectorStore (InMemory m) where - -- \| Add documents with generated embeddings - -- Example: - -- - -- >>> addDocuments inMem [doc1, doc2] - -- Right (InMemory {_store = ...}) - -- addDocuments inMem docs = do - eRes <- embedDocuments (embeddingModel inMem) docs - case eRes of - Left err -> pure $ Left err - Right floats -> do - let currStore = store inMem - mbMaxKey = Map.lookupMax currStore - newStore = - Map.fromList $ - zip - [(maybe 1 (\x -> fst x + 1) mbMaxKey) ..] - (zip docs floats) - newInMem = inMem {store = Map.union newStore currStore} - pure $ Right newInMem + floats <- embedDocuments (embeddingModel inMem) docs + let currStore = store inMem + mbMaxKey = Map.lookupMax currStore + startIdx = maybe 1 (\(k, _) -> k + 1) mbMaxKey + newEntries = Map.fromList $ zip [startIdx ..] (zip docs floats) + newInMem = inMem {store = Map.union newEntries currStore} + pure newInMem - -- \| Delete documents by ID - -- Example: - -- - -- >>> delete inMem [1, 2] - -- Right (InMemory {_store = ...}) - -- delete inMem ids = do let currStore = store inMem newStore = foldl (flip Map.delete) currStore ids - newInMem = inMem {store = newStore} - pure $ Right newInMem + pure inMem {store = newStore} - -- \| Text-based similarity search - -- Example: - -- - -- >>> similaritySearch inMem "Haskell" 2 - -- Right [Document "Haskell is...", Document "Functional programming..."] - -- similaritySearch vs query k = do - eQueryEmbedding <- embedQuery (embeddingModel vs) query - case eQueryEmbedding of - Left err -> return $ Left err - Right queryVec -> similaritySearchByVector vs queryVec k + queryVec <- embedQuery (embeddingModel vs) query + similaritySearchByVector vs queryVec k - -- \| Vector-based similarity search - -- Uses cosine similarity for ranking - -- - -- Example: - -- - -- >>> similaritySearchByVector inMem [0.1, 0.3, ...] 3 - -- Right [mostRelevantDoc, ...] - -- similaritySearchByVector vs queryVec k = do let similarities = map (second (cosineSimilarity queryVec) . snd) (Map.toList $ store vs) sorted = sortBy (comparing (negate . snd)) similarities - -- Sort in descending order topK = take k sorted - return $ Right $ map fst topK - -{- -ghci> let x = OllamaEmbeddings "nomic-embed-text:latest" Nothing Nothing -ghci> let inMem = emptyInMemoryVectorStore x -ghci> eRes <- addDocuments inMem [Document "Hello World" empty, Document "Nice to meet you" empty] -ghci> let newInMem = fromRight inMem eRes -ghci> similaritySearch newInMem "World" 1 -Right [Document {pageContent = "Hello World", metadata = fromList []}] -ghci> similaritySearch newInMem "Meet you" 1 -Right [Document {pageContent = "Nice to meet you", metadata = fromList []}] --} - -{- $examples -Test case patterns: -1. Document addition - >>> addDocuments inMem [Document "Test" mempty] - Right (InMemory {_store = ...}) - -2. Similarity search - >>> similaritySearch inMem "World" 1 - Right [Document "Hello World"...] - -3. Vector-based search - >>> similaritySearchByVector inMem [0.5, 0.5] 1 - Right [mostSimilarDoc] --} + pure $ map fst topK diff --git a/src/Langchain/VectorStore/SqliteVec.hs b/src/Langchain/VectorStore/SqliteVec.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/VectorStore/SqliteVec.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Langchain.VectorStore.SqliteVec +Description : SQLite-backed vector store with persistent storage and cosine distance +Copyright : (c) 2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Stores document text, JSON metadata, and vector embeddings in a local SQLite database. +-} +module Langchain.VectorStore.SqliteVec + ( SqliteVecStore (..) + , newSqliteVecStore + , initSqliteVecSchema + ) where + +import Control.Exception (try) +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (decode, encode) +import qualified Data.ByteString.Lazy as LBS +import Data.Int (Int64) +import Data.List (sortOn) +import Data.Maybe (fromMaybe) +import Data.Ord (Down (..)) +import qualified Data.Text as TS +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL +import Database.SQLite.Simple + +import Langchain.Core.Error (LangchainError, vectorStoreError) +import Langchain.DocumentLoader.Core (Document (..)) +import Langchain.Embeddings.Core (Embeddings (..)) +import Langchain.VectorStore.Core (VectorStore (..)) +import Langchain.VectorStore.InMemory (cosineSimilarity) + +-- | SQLite vector store container +data SqliteVecStore e = SqliteVecStore + { sqliteDbPath :: FilePath + , sqliteEmbeddings :: e + } + +-- | Construct a new SqliteVecStore and initialize schema +newSqliteVecStore :: + (MonadIO m, MonadError LangchainError m) => + FilePath -> + e -> + m (SqliteVecStore e) +newSqliteVecStore dbPath emb = do + initSqliteVecSchema dbPath + pure $ SqliteVecStore dbPath emb + +-- | Initialize table schema in SQLite database +initSqliteVecSchema :: (MonadIO m, MonadError LangchainError m) => FilePath -> m () +initSqliteVecSchema dbPath = do + eRes <- liftIO $ try $ withConnection dbPath $ \conn -> do + execute_ + conn + "CREATE TABLE IF NOT EXISTS langchain_vectors (\ + \ id INTEGER PRIMARY KEY AUTOINCREMENT,\ + \ content TEXT NOT NULL,\ + \ metadata TEXT NOT NULL,\ + \ vector BLOB NOT NULL\ + \);" + case eRes of + Left err -> + throwError $ + vectorStoreError + (TS.pack $ "Failed to initialize SQLite vector database: " ++ show (err :: IOError)) + (Just "SqliteVecStore") + Nothing + Right () -> pure () + +instance (Embeddings e) => VectorStore (SqliteVecStore e) where + addDocuments store docs = do + vectors <- embedDocuments (sqliteEmbeddings store) docs + eRes <- liftIO $ try $ withConnection (sqliteDbPath store) $ \conn -> do + withTransaction conn $ do + mapM_ + ( \(doc, vec) -> do + let cTxt = TL.unpack (pageContent doc) + mJson = TE.decodeUtf8 $ LBS.toStrict $ encode (metadata doc) + vBytes = LBS.toStrict $ encode (vec :: [Float]) + execute + conn + "INSERT INTO langchain_vectors (content, metadata, vector) VALUES (?, ?, ?)" + (cTxt, TS.unpack mJson, vBytes) + ) + (zip docs vectors) + case eRes of + Left err -> + throwError $ + vectorStoreError + (TS.pack $ "Failed to insert documents into SQLite vector store: " ++ show (err :: IOError)) + (Just "SqliteVecStore") + Nothing + Right () -> pure store + + delete store ids = do + eRes <- liftIO $ try $ withConnection (sqliteDbPath store) $ \conn -> do + withTransaction conn $ do + mapM_ + (\i -> execute conn "DELETE FROM langchain_vectors WHERE id = ?" (Only (i :: Int64))) + ids + case eRes of + Left err -> + throwError $ + vectorStoreError + (TS.pack $ "Failed to delete documents from SQLite vector store: " ++ show (err :: IOError)) + (Just "SqliteVecStore") + Nothing + Right () -> pure store + + similaritySearch store query0 k = do + qVec <- embedQuery (sqliteEmbeddings store) query0 + similaritySearchByVector store qVec k + + similaritySearchByVector store qVec k = do + rowsRes <- liftIO $ try $ withConnection (sqliteDbPath store) $ \conn -> do + query_ conn "SELECT id, content, metadata, vector FROM langchain_vectors" :: + IO [(Int64, String, String, LBS.ByteString)] + rows <- case rowsRes of + Left err -> + throwError $ + vectorStoreError + (TS.pack $ "Failed to query SQLite vector store: " ++ show (err :: IOError)) + (Just "SqliteVecStore") + Nothing + Right r -> pure r + + let scoredDocs = + [ (score, doc) + | (_, contentStr, metaStr, vBytes) <- rows + , let mbVec = decode (LBS.fromStrict (LBS.toStrict vBytes)) :: Maybe [Float] + , Just vec <- [mbVec] + , let score = cosineSimilarity qVec vec + , let mbMeta = decode (LBS.fromStrict (TE.encodeUtf8 (TS.pack metaStr))) + , let meta = fromMaybe mempty mbMeta + , let doc = Document (TL.pack contentStr) meta + ] + topK = take k $ map snd $ sortOn (Down . fst) scoredDocs + pure topK diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,46 +1,150 @@ -import qualified Test.Langchain.Agent.ReAct as ReActTest +{-# LANGUAGE OverloadedStrings #-} --- import qualified Test.Langchain.Agent.ReactAgent as ReactAgentTest +module Main (main) where + +import Test.Tasty + +-- Unit Test Modules +import qualified Test.Langchain.Agent.AdvancedAgentsSpec as AdvancedAgentsTest +import qualified Test.Langchain.Agent.ReAct as ReActTest +import qualified Test.Langchain.Cache.CacheSpec as CacheTest +import qualified Test.Langchain.Callback.CallbackManagerSpec as CallbackTest +import qualified Test.Langchain.Chain.ChainsSpec as ChainsTest +import qualified Test.Langchain.Chain.RetrievalQASpec as RetrievalQATest import qualified Test.Langchain.DocumentLoader.Core as DocumentLoaderTest +import qualified Test.Langchain.DocumentLoader.CsvSpec as CsvLoaderTest import qualified Test.Langchain.DocumentLoader.DirectoryLoader as DirectoryLoaderTest -import qualified Test.Langchain.Embeddings.Core as EmbeddingsTest -import qualified Test.Langchain.LLM.Core as LLMCoreTest -import qualified Test.Langchain.LLM.Ollama as OllamaLLMTest +import qualified Test.Langchain.Error as ErrorTest +import qualified Test.Langchain.Graph.CompilationSpec as GraphCompilationTest +import qualified Test.Langchain.Guardrail.GuardrailSpec as GuardrailTest +import qualified Test.Langchain.MCP.McpSpec as McpTest import qualified Test.Langchain.Memory.Core as MemoryTest +import qualified Test.Langchain.Memory.EntitySpec as EntityMemoryTest +import qualified Test.Langchain.Memory.SummarySpec as SummaryMemoryTest import qualified Test.Langchain.Memory.TokenBufferMemory as TokenBufferMemoryTest +import qualified Test.Langchain.ObservabilitySpec as ObservabilityTest +import qualified Test.Langchain.OutputParser.AdvancedParsersSpec as AdvancedParsersTest import qualified Test.Langchain.OutputParser.Core as OutputParserTest -import qualified Test.Langchain.PromptTemplate as PromptTemplateTest +import qualified Test.Langchain.PromptTemplate.Chat.ChatPromptTemplateSpec as ChatPromptTemplateTest +import qualified Test.Langchain.PromptTemplate.Chat.MessagesPlaceholderSpec as MessagesPlaceholderTest +import qualified Test.Langchain.PromptTemplate.FewShotSpec as FewShotPromptTemplateTest +import qualified Test.Langchain.PromptTemplate.PromptSpec as PromptTemplateTest +import qualified Test.Langchain.Provider.FixturesSpec as FixturesTest +import qualified Test.Langchain.Provider.Ollama as OllamaProviderTest +import qualified Test.Langchain.Provider.OllamaConversionSpec as OllamaConversionTest +import qualified Test.Langchain.Provider.OpenAI as OpenAIProviderTest +import qualified Test.Langchain.Resilience.CircuitBreakerSpec as CircuitBreakerTest +import qualified Test.Langchain.Resilience.RetrySpec as RetryTest +import qualified Test.Langchain.Retriever.BM25Spec as BM25Test import qualified Test.Langchain.Retriever.Core as RetrieverTest -import qualified Test.Langchain.Runnable.Chains as RunnableChainsTest -import qualified Test.Langchain.Runnable.ConversationChains as ConverationChainsTest -import qualified Test.Langchain.Runnable.Core as RunnableTest -import qualified Test.Langchain.Runnable.Utils as RunnableUtilsTest +import qualified Test.Langchain.Retriever.HybridSpec as HybridRetrieverTest import qualified Test.Langchain.TextSplitter.Character as TextSplitterTest -import qualified Test.Langchain.Tool.Core as ToolTest +import qualified Test.Langchain.TextSplitter.CodeSpec as CodeSplitterTest +import qualified Test.Langchain.TextSplitter.MarkdownSpec as MarkdownSplitterTest +import qualified Test.Langchain.TextSplitter.RecursiveCharacterSpec as RecursiveSplitterTest +import qualified Test.Langchain.TextSplitter.TokenSpec as TokenSplitterTest +import qualified Test.Langchain.Tool.AdvancedToolsSpec as AdvancedToolsTest +import qualified Test.Langchain.Tool.Calculator as CalculatorToolTest +import qualified Test.Langchain.Tool.FileSystem as FileSystemToolTest +import qualified Test.Langchain.Tool.Shell as ShellToolTest import qualified Test.Langchain.VectorStore.Core as VectorStoreTest -import Test.Tasty +import qualified Test.Langchain.VectorStore.SqliteVecSpec as SqliteVecStoreTest +-- Property Test Modules (QuickCheck Laws & Invariants) +import qualified Test.Langchain.Property.CheckpointerSpec as CheckpointerPropTest +import qualified Test.Langchain.Property.ErrorSpec as ErrorPropTest +import qualified Test.Langchain.Property.MessageSpec as MessagePropTest +import qualified Test.Langchain.Property.PromptTemplateSpec as PromptTemplatePropTest +import qualified Test.Langchain.Property.RunnableSpec as RunnablePropTest +import qualified Test.Langchain.Property.TextSplitterSpec as TextSplitterPropTest + +-- Regression Test Module +import qualified Test.Langchain.RegressionSpec as RegressionTest + +-- Live Ollama E2E Integration Test Modules +import qualified Test.Langchain.Integration.FullRagE2ESpec as FullRagE2ETest +import qualified Test.Langchain.Integration.OllamaChatSpec as OllamaChatE2ETest +import qualified Test.Langchain.Integration.OllamaEmbeddingSpec as OllamaEmbedE2ETest +import qualified Test.Langchain.Integration.OllamaStreamSpec as OllamaStreamE2ETest +import qualified Test.Langchain.Integration.OllamaToolSpec as OllamaToolE2ETest +import qualified Test.Langchain.Integration.ReActAgentE2ESpec as ReActE2ETest +import qualified Test.Langchain.Integration.StateGraphE2ESpec as StateGraphE2ETest +import qualified Test.Langchain.Integration.StreamingCachingRetryE2ESpec as StreamingCachingRetryE2ETest + main :: IO () main = defaultMain $ testGroup - "Langchain" - [ LLMCoreTest.tests - , OllamaLLMTest.tests - , PromptTemplateTest.tests - , OutputParserTest.tests - , TextSplitterTest.tests - , DocumentLoaderTest.tests - , DirectoryLoaderTest.tests - , MemoryTest.tests - , VectorStoreTest.tests - , EmbeddingsTest.tests - , RetrieverTest.tests - , ToolTest.tests - , ReActTest.tests - , RunnableTest.tests - , RunnableUtilsTest.tests - , RunnableChainsTest.tests - , ConverationChainsTest.tests - , TokenBufferMemoryTest.tests + "Langchain Test Suite" + [ testGroup + "Unit Tests" + [ PromptTemplateTest.tests + , FewShotPromptTemplateTest.tests + , ChatPromptTemplateTest.tests + , MessagesPlaceholderTest.tests + , OutputParserTest.tests + , AdvancedParsersTest.tests + , TextSplitterTest.tests + , RecursiveSplitterTest.tests + , MarkdownSplitterTest.tests + , TokenSplitterTest.tests + , CodeSplitterTest.tests + , DocumentLoaderTest.tests + , DirectoryLoaderTest.tests + , CsvLoaderTest.tests + , MemoryTest.tests + , SummaryMemoryTest.tests + , EntityMemoryTest.tests + , VectorStoreTest.tests + , SqliteVecStoreTest.tests + , ErrorTest.tests + , RetrieverTest.tests + , BM25Test.tests + , HybridRetrieverTest.tests + , RetrievalQATest.tests + , ChainsTest.tests + , CacheTest.tests + , RetryTest.tests + , CircuitBreakerTest.tests + , AdvancedToolsTest.tests + , ReActTest.tests + , AdvancedAgentsTest.tests + , GuardrailTest.tests + , McpTest.tests + , ObservabilityTest.tests + , CallbackTest.tests + , TokenBufferMemoryTest.tests + , OllamaProviderTest.tests + , OllamaConversionTest.tests + , OpenAIProviderTest.tests + , FixturesTest.tests + , CalculatorToolTest.tests + , FileSystemToolTest.tests + , ShellToolTest.tests + , GraphCompilationTest.tests + ] + , testGroup + "Property Tests (Laws & Invariants)" + [ MessagePropTest.tests + , PromptTemplatePropTest.tests + , TextSplitterPropTest.tests + , RunnablePropTest.tests + , CheckpointerPropTest.tests + , ErrorPropTest.tests + ] + , testGroup + "Regression Tests" + [ RegressionTest.tests + ] + , testGroup + "Live E2E Integration Tests (Ollama)" + [ OllamaChatE2ETest.tests + , OllamaStreamE2ETest.tests + , OllamaToolE2ETest.tests + , OllamaEmbedE2ETest.tests + , FullRagE2ETest.tests + , ReActE2ETest.tests + , StateGraphE2ETest.tests + , StreamingCachingRetryE2ETest.tests + ] ] diff --git a/test/Test/Langchain/Agent/AdvancedAgentsSpec.hs b/test/Test/Langchain/Agent/AdvancedAgentsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Agent/AdvancedAgentsSpec.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Agent.AdvancedAgentsSpec (tests) where + +import Control.Monad.Except (ExceptT, runExceptT) +import qualified Data.Text as T +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Agent.PlanAndExecute +import Langchain.Core.Error (LangchainError) +import Test.Langchain.Provider.Mock (newMockModel) + +tests :: TestTree +tests = + testGroup + "Langchain.Agent.AdvancedAgentsSpec" + [ testCase "PlanAndExecuteAgent plans with JSON structured output and executes sequentially" $ do + let planner = + newMockModel + "{\"planSteps\": [{\"stepNumber\": 1, \"stepDescription\": \"Research Haskell\"}, {\"stepNumber\": 2, \"stepDescription\": \"Write code\"}, {\"stepNumber\": 3, \"stepDescription\": \"Run tests\"}]}" + executor = newMockModel "Executed step successfully." + agent = newPlanAndExecuteAgent planner executor Nothing + res <- runExceptT $ runPlanAndExecute agent "Build a Haskell library" + case res of + Left err -> assertFailure ("PlanAndExecute failed: " ++ show err) + Right ans -> ans @?= "Executed step successfully." + , testCase "PlanAndExecuteAgent executes agent step executor" $ do + let planner = newMockModel "{\"planSteps\": [{\"stepNumber\": 1, \"stepDescription\": \"Calculate sum\"}]}" + agentExecutor :: T.Text -> ExceptT LangchainError IO T.Text + agentExecutor _ = pure "Result: 42" + agent = newPlanAndExecuteAgent planner agentExecutor Nothing + res <- runExceptT $ runPlanAndExecute agent "Compute answer" + case res of + Left err -> assertFailure ("PlanAndExecute failed: " ++ show err) + Right ans -> ans @?= "Result: 42" + ] diff --git a/test/Test/Langchain/Agent/ReAct.hs b/test/Test/Langchain/Agent/ReAct.hs --- a/test/Test/Langchain/Agent/ReAct.hs +++ b/test/Test/Langchain/Agent/ReAct.hs @@ -1,210 +1,170 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Test.Langchain.Agent.ReAct (tests) where -import Data.Aeson (object, (.=)) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as Map -import Data.Text (Text) -import Langchain.Agent.Core -import Langchain.Agent.ReAct -import Langchain.Error (LangchainError, llmError) -import Langchain.LLM.Core -import Langchain.Memory.Core (BaseMemory (..), WindowBufferMemory (..)) -import Langchain.Tool.Core +import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value (..), object, (.=)) +import qualified Data.Aeson.KeyMap as KeyMap +import Data.IORef +import qualified Data.Text as T import Test.Tasty import Test.Tasty.HUnit --- Mock LLM for testing -newtype MockLLM = MockLLM - { mockResponse :: Either LangchainError Message - } - -instance LLM MockLLM where - type LLMParams MockLLM = () - type LLMStreamTokenType MockLLM = Text +import Langchain.Agent.ReAct +import Langchain.Core.Error (LangchainError) +import Langchain.Core.Model +import Langchain.Core.Tool (Tool) +import Langchain.Provider.Gemini (Gemini) +import Langchain.Provider.Ollama (ChatRequest (..), Ollama, chatTools) +import Langchain.Provider.OpenAI (OpenAI) +import Langchain.Tool.Binding (ToolBinder (..)) +import Langchain.Tool.Calculator (calculatorTool) +import Test.Langchain.Provider.Mock (newMockModel) - generate _ _ _ = pure $ Left $ llmError "Not implemented" Nothing Nothing +-- | Mock model that records the config received by invoke +data ConfigRecordingModel = ConfigRecordingModel (IORef (Maybe Value)) T.Text - chat llm _ _ = pure $ mockResponse llm +instance ChatModel ConfigRecordingModel where + type ModelConfig ConfigRecordingModel = Value + invoke (ConfigRecordingModel ref resp) _ mbCfg = do + liftIO $ writeIORef ref mbCfg + pure $ assistantMessage resp + stream = error "stream not supported in ConfigRecordingModel" - stream _ _ _ _ = pure $ Left $ llmError "Not implemented" Nothing Nothing +instance ToolBinder ConfigRecordingModel m where + bindToolsConfig tools _ = + Just $ object ["tool_count" .= length tools] --- Mock Tool for testing -newtype MockTool = MockTool Text - deriving (Show, Eq) +-- | Mock model that yields a pre-configured sequence of responses and logs history +data StepSequenceModel = StepSequenceModel (IORef [Message]) (IORef [[Message]]) -instance Tool MockTool where - type Input MockTool = ToolCall - type Output MockTool = Text +instance ChatModel StepSequenceModel where + type ModelConfig StepSequenceModel = Value + invoke (StepSequenceModel stepsRef histRef) history _ = liftIO $ do + modifyIORef histRef (++ [history]) + steps <- readIORef stepsRef + case steps of + [] -> pure $ assistantMessage "Default response" + (m : rest) -> do + writeIORef stepsRef rest + pure m + stream = error "stream not supported in StepSequenceModel" - toolName (MockTool toolName_) = toolName_ - toolDescription _ = "A mock tool for testing" - runTool _ tc = pure $ "Executed: " <> toolFunctionName (toolCallFunction tc) +instance ToolBinder StepSequenceModel m where + bindToolsConfig _ _ = Nothing tests :: TestTree tests = testGroup - "Agent.ReAct" - [ testPlanReturnsFinishWhenNoToolCalls - , testPlanReturnsActionWhenToolCallsPresent - , testPlanPropagatesLLMError - , testExecuteToolFindsCorrectTool - , testExecuteToolReturnsErrorWhenToolNotFound - , testInitializeSetsUpStateCorrectly + "Langchain.Agent.ReAct" + [ testCase "reactStep returns AgentFinish when LLM responds with plain text" $ do + let mockModel = newMockModel "The answer is 4." + agent = createReActAgent mockModel [calculatorTool] + res <- runExceptT $ reactStep (agentModel agent) (agentTools agent) [userMessage "What is 2+2?"] + case res of + Left err -> assertFailure $ "Unexpected error: " ++ show err + Right step -> case step of + AgentFinish msg -> T.strip (extractMessageText msg) @?= "The answer is 4." + _ -> assertFailure "Expected AgentFinish" + , testCase "reactStep returns AgentAction with all tool calls" $ do + let tc1 = ToolCall "call_1" "function" "calculator" (object ["expression" .= ("2+2" :: T.Text)]) + tc2 = ToolCall "call_2" "function" "calculator" (object ["expression" .= ("3*3" :: T.Text)]) + respWithTools = (assistantMessage "") {messageToolCalls = Just [tc1, tc2]} + sRef <- newIORef [respWithTools] + hRef <- newIORef [] + let model = StepSequenceModel sRef hRef + agent = createReActAgent model [calculatorTool :: Tool (ExceptT LangchainError IO)] + res <- runExceptT $ reactStep (agentModel agent) (agentTools agent) [userMessage "Calculate both"] + case res of + Left err -> assertFailure $ "Unexpected error: " ++ show err + Right step -> case step of + AgentAction _ tcs -> length tcs @?= 2 + _ -> assertFailure "Expected AgentAction with multiple tool calls" + , testCase "runReActAgent executes multiple parallel tool calls and reaches finish" $ do + let tc1 = ToolCall "call_1" "function" "calculator" (object ["expression" .= ("2+2" :: T.Text)]) + tc2 = ToolCall "call_2" "function" "calculator" (object ["expression" .= ("5*2" :: T.Text)]) + respWithTools = (assistantMessage "calculating") {messageToolCalls = Just [tc1, tc2]} + finalResp = assistantMessage "4 and 10" + sRef <- newIORef [respWithTools, finalResp] + hRef <- newIORef [] + let model = StepSequenceModel sRef hRef + agent = createReActAgent model [calculatorTool :: Tool (ExceptT LangchainError IO)] + res <- runExceptT $ runReActAgent agent [userMessage "Calculate 2+2 and 5*2"] + case res of + Left err -> assertFailure $ "Unexpected error: " ++ show err + Right finalMsg -> do + T.strip (extractMessageText finalMsg) @?= "4 and 10" + -- Verify history in step 2 received observations for BOTH tool calls + histories <- readIORef hRef + case histories of + [_, secondCallHistory] -> do + let toolMsgs = filter (\m -> messageRole m == Tool) secondCallHistory + length toolMsgs @?= 2 + map messageToolId toolMsgs @?= [Just "call_1", Just "call_2"] + _ -> assertFailure $ "Expected 2 invocations, got: " ++ show (length histories) + , testCase "runReActAgent handles unknown tool gracefully via observation error" $ do + let tc = ToolCall "call_bad" "function" "unknown_tool" (object []) + respWithBadTool = (assistantMessage "") {messageToolCalls = Just [tc]} + finalResp = assistantMessage "Handled missing tool" + sRef <- newIORef [respWithBadTool, finalResp] + hRef <- newIORef [] + let model = StepSequenceModel sRef hRef + agent = createReActAgent model [calculatorTool :: Tool (ExceptT LangchainError IO)] + res <- runExceptT $ runReActAgent agent [userMessage "Run unknown tool"] + case res of + Left err -> assertFailure $ "Expected recovery but got error: " ++ show err + Right finalMsg -> do + T.strip (extractMessageText finalMsg) @?= "Handled missing tool" + histories <- readIORef hRef + case histories of + [_, secondCallHistory] -> do + let toolMsgs = filter (\m -> messageRole m == Tool) secondCallHistory + length toolMsgs @?= 1 + case toolMsgs of + (m : _) -> + assertBool "Error observation" ("Tool not found: unknown_tool" `T.isInfixOf` extractMessageText m) + _ -> assertFailure "Expected tool message" + _ -> assertFailure "Expected 2 invocations" + , testCase "runReActAgent completes full loop on finish" $ do + let mockModel = newMockModel "Finished processing" + agent = createReActAgent mockModel [calculatorTool] + res <- runExceptT $ runReActAgent agent [userMessage "Hello"] + case res of + Left err -> assertFailure $ "Unexpected error: " ++ show err + Right finalMsg -> T.strip (extractMessageText finalMsg) @?= "Finished processing" + , testCase "reactStep passes bound tools config to model invoke" $ do + ref <- newIORef Nothing + let recordingModel = ConfigRecordingModel ref "Direct Answer" + tools = [calculatorTool :: Tool (ExceptT LangchainError IO)] + res <- runExceptT $ reactStep recordingModel tools [userMessage "Calculate 2+2"] + case res of + Left err -> assertFailure $ "Unexpected error: " ++ show err + Right _ -> do + captured <- readIORef ref + captured @?= Just (object ["tool_count" .= (1 :: Int)]) + , testCase "ToolBinder Ollama attaches tools to ChatRequest config" $ do + let tools = [calculatorTool :: Tool IO] + mbCfg = bindToolsConfig @Ollama tools Nothing + case mbCfg of + Nothing -> assertFailure "Expected Just ChatRequest" + Just req -> case chatTools req of + Nothing -> assertFailure "Expected Just tools in ChatRequest" + Just ts -> length ts @?= 1 + , testCase "ToolBinder OpenAI attaches tools to JSON config" $ do + let tools = [calculatorTool :: Tool IO] + mbCfg = bindToolsConfig @OpenAI tools Nothing + case mbCfg of + Just (Object obj) -> assertBool "Has 'tools' key" (KeyMap.member "tools" obj) + _ -> assertFailure "Expected Just Object with tools" + , testCase "ToolBinder Gemini attaches tools to JSON config" $ do + let tools = [calculatorTool :: Tool IO] + mbCfg = bindToolsConfig @Gemini tools Nothing + case mbCfg of + Just (Object obj) -> assertBool "Has 'tools' key" (KeyMap.member "tools" obj) + _ -> assertFailure "Expected Just Object with tools" ] - --- Test that plan returns AgentFinish when LLM returns no tool calls -testPlanReturnsFinishWhenNoToolCalls :: TestTree -testPlanReturnsFinishWhenNoToolCalls = testCase "plan returns AgentFinish when no tool calls" $ do - let mockMsg = Message Assistant "Final answer" defaultMessageData - mockLLM = MockLLM (Right mockMsg) - agent = createReActAgent mockLLM Nothing [] - testMemory = WindowBufferMemory 10 (NE.fromList [defaultMessage {content = "test"}]) - state = - AgentState - { agentMemory = SomeMemory testMemory - , agentInput = "test input" - , agentIterations = 0 - } - - result <- plan agent state - case result of - Right (Done finish) -> do - assertEqual "Output should match content" "Final answer" (agentOutput finish) - assertEqual "Log should match content" "Final answer" (finishLog finish) - _ -> assertFailure $ "Expected Right (Right AgentFinish), got: " ++ show result - --- Test that plan returns AgentAction when LLM returns tool calls -testPlanReturnsActionWhenToolCallsPresent :: TestTree -testPlanReturnsActionWhenToolCallsPresent = testCase "plan returns AgentAction when tool calls present" $ do - let toolCall = - ToolCall - { toolCallId = "call_123" - , toolCallType = "function" - , toolCallFunction = - ToolFunction - { toolFunctionName = "search" - , toolFunctionArguments = Map.fromList [("query", object ["text" .= ("test" :: Text)])] - } - } - msgData = defaultMessageData {toolCalls = Just [toolCall]} - mockMsg = Message Assistant "Let me search" msgData - mockLLM = MockLLM (Right mockMsg) - agent = createReActAgent mockLLM Nothing [] - testMemory = WindowBufferMemory 10 (NE.fromList [defaultMessage {content = "test"}]) - state = - AgentState - { agentMemory = SomeMemory testMemory - , agentInput = "test input" - , agentIterations = 0 - } - - result <- plan agent state - case result of - Right (Continue action) -> do - assertEqual "Should have one tool call" 1 (length $ actionToolCall action) - assertEqual "Log should match content" "Let me search" (actionLog action) - _ -> assertFailure $ "Expected Right (Left AgentAction), got: " ++ show result - --- Test that plan propagates LLM errors -testPlanPropagatesLLMError :: TestTree -testPlanPropagatesLLMError = testCase "plan propagates LLM error" $ do - let mockError = llmError "LLM failed" Nothing Nothing - mockLLM = MockLLM (Left mockError) - agent = createReActAgent mockLLM Nothing [] - testMemory = WindowBufferMemory 10 (NE.fromList [defaultMessage {content = "test"}]) - state = - AgentState - { agentMemory = SomeMemory testMemory - , agentInput = "test input" - , agentIterations = 0 - } - - result <- plan agent state - case result of - Left _ -> pure () -- Expected error - Right _ -> assertFailure "Expected Left error, got Right" - --- Test that executeTool finds and executes the correct tool -testExecuteToolFindsCorrectTool :: TestTree -testExecuteToolFindsCorrectTool = testCase "executeTool finds and executes correct tool" $ do - let tool1 = ToolAcceptingToolCall (MockTool "tool1") - tool2 = ToolAcceptingToolCall (MockTool "tool2") - mockLLM = MockLLM (Right defaultMessage) - agent = createReActAgent mockLLM Nothing [tool1, tool2] - toolCall = - ToolCall - { toolCallId = "call_123" - , toolCallType = "function" - , toolCallFunction = - ToolFunction - { toolFunctionName = "tool2" - , toolFunctionArguments = Map.empty - } - } - - result <- executeTool agent toolCall - case result of - Right output -> do - assertEqual "Should execute tool2" "Executed: tool2" output - Left err -> assertFailure $ "Expected Right, got error: " ++ show err - --- Test that executeTool returns error when tool not found -testExecuteToolReturnsErrorWhenToolNotFound :: TestTree -testExecuteToolReturnsErrorWhenToolNotFound = testCase "executeTool returns error when tool not found" $ do - let tool1 = ToolAcceptingToolCall (MockTool "tool1") - mockLLM = MockLLM (Right defaultMessage) - agent = createReActAgent mockLLM Nothing [tool1] - toolCall = - ToolCall - { toolCallId = "call_123" - , toolCallType = "function" - , toolCallFunction = - ToolFunction - { toolFunctionName = "nonexistent" - , toolFunctionArguments = Map.empty - } - } - - result <- executeTool agent toolCall - case result of - Left _ -> pure () -- Expected error - Right _ -> assertFailure "Expected error for nonexistent tool" - --- Test that initialize sets up state correctly -testInitializeSetsUpStateCorrectly :: TestTree -testInitializeSetsUpStateCorrectly = testCase "initialize sets up state correctly" $ do - let mockLLM = MockLLM (Right defaultMessage) - agent = createReActAgent mockLLM Nothing [] - testMemory = WindowBufferMemory 10 (NE.fromList [defaultMessage]) - inputState = - AgentState - { agentMemory = SomeMemory testMemory - , agentInput = "What is 2+2?" - , agentIterations = 0 - } - - result <- initialize agent inputState - case result of - Right newState -> do - assertEqual "Input should be preserved" "What is 2+2?" (agentInput newState) - assertEqual "Iterations should be 0" 0 (agentIterations newState) - - -- Check chat history has system message and user message by accessing memory - case agentMemory newState of - SomeMemory mem -> do - eHistory <- messages mem - case eHistory of - Right history -> do - let historyList = NE.toList history - assertEqual "Should have 3 messages (initial + system + user)" 3 (length historyList) - case reverse historyList of - (userMsg : sysMsg : _) -> do - assertEqual "Last message should be User" User (role userMsg) - assertEqual "Second to last message should be System" System (role sysMsg) - assertEqual "User message content should match input" "What is 2+2?" (content userMsg) - _ -> assertFailure "Expected at least 2 messages in history" - Left err -> assertFailure $ "Failed to get messages from memory: " ++ show err - Left err -> assertFailure $ "Expected Right, got error: " ++ show err diff --git a/test/Test/Langchain/Cache/CacheSpec.hs b/test/Test/Langchain/Cache/CacheSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Cache/CacheSpec.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Cache.CacheSpec (tests) where + +import Control.Concurrent.STM (newTVarIO) +import Control.Monad.Except (runExceptT) +import Data.Aeson (Value, object, (.=)) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Cache.Core +import Langchain.Core.Model + ( ChatModel (..) + , ContentBlock (..) + , ImageContent (..) + , ImageSource (..) + , Message (..) + , Role (..) + , ToolCall (..) + , assistantMessage + , extractMessageText + , userMessage + ) +import Langchain.Provider.Gemini (Gemini (..)) +import Langchain.Provider.Ollama (Ollama, newOllamaWithClient) +import Langchain.Provider.OpenAI (OpenAI (OpenAI)) +import qualified Ollama.API.Chat as OllamaChat +import Ollama.Client (newClient) +import qualified Ollama.Client.Config as OllamaClientConfig +import Ollama.Types.Common (ModelName (..), Think (..)) +import Ollama.Types.Format (Format (..)) +import qualified Ollama.Types.Message as OllamaMessage +import Ollama.Types.Options (ModelOptions (..), defaultOptions) +import Ollama.Types.Tool (FunctionDef (..)) +import qualified Ollama.Types.Tool as OllamaTool +import Test.Langchain.Provider.Mock (MockModel (..), newMockModel) + +testMessages :: [Message] +testMessages = [userMessage "Describe the image"] + +baseOllamaRequest :: OllamaChat.ChatRequest +baseOllamaRequest = + OllamaChat.chatRequest + (ModelName "llama3.2") + (OllamaMessage.userMessage "ignored-message" :| []) + +newOllamaForEndpoint :: Text -> IO Ollama +newOllamaForEndpoint endpoint = do + ollamaClient <- + newClient $ + OllamaClientConfig.defaultConfig + { OllamaClientConfig.configBaseUrl = endpoint + } + pure $ newOllamaWithClient "llama3.2" ollamaClient + +assertKeysDiffer :: Text -> Text -> Assertion +assertKeysDiffer first second = + assertBool "Expected cache keys to differ" (first /= second) + +tests :: TestTree +tests = + testGroup + "Langchain.Cache.CacheSpec" + [ testCase "InMemoryCache stores and retrieves cached message" $ do + cache <- newInMemoryCache + let msg = assistantMessage "Cached result" + putCache cache "key1" msg + res <- getCache cache "key1" + res @?= Just msg + clearCache cache + resAfter <- getCache cache "key1" + resAfter @?= Nothing + , testCase "SQLiteCache stores and persists message across queries" $ do + withSystemTempDirectory "sqlite-cache-test" $ \tmpDir -> do + let dbPath = tmpDir "cache.db" + cache <- newSQLiteCache dbPath + let msg = assistantMessage "SQLite Cached" + putCache cache "keyA" msg + res <- getCache cache "keyA" + res @?= Just msg + , testCase "CachedModel caches response and returns cached on second call" $ do + _ <- newTVarIO (0 :: Int) + let mockModel = newMockModel "Dynamic Output" + cache <- newInMemoryCache + let cachedModel = withCaching mockModel cache + msgs = [userMessage "Compute 2+2"] + res1 <- runExceptT $ invoke cachedModel msgs Nothing + res2 <- runExceptT $ invoke cachedModel msgs Nothing + case (res1, res2) of + (Right m1, Right m2) -> do + extractMessageText m1 @?= "Dynamic Output" + extractMessageText m2 @?= "Dynamic Output" + _ -> assertFailure "Expected successful CachedModel invocations" + , testCase "cache key is stable for identical inputs" $ do + let mockModel = newMockModel "Dynamic Output" + computeCacheKey mockModel Nothing testMessages + @?= computeCacheKey mockModel Nothing testMessages + , testCase "cache key distinguishes complete message content" $ do + let mockModel = newMockModel "Dynamic Output" + imageMessage = + Message + User + ( TextBlock "Describe the image" + :| [ImageBlock $ ImageContent (ImageUrl "https://example.com/image.png") Nothing Nothing] + ) + Nothing + Nothing + Nothing + Map.empty + toolMessage = + (userMessage "Describe the image") + { messageToolCalls = Just [ToolCall "call-1" "function" "describe_image" (object [])] + } + baseKey = computeCacheKey mockModel Nothing testMessages + assertKeysDiffer baseKey $ computeCacheKey mockModel Nothing [imageMessage] + assertKeysDiffer baseKey $ computeCacheKey mockModel Nothing [toolMessage] + , testCase "cache key distinguishes mock model identity" $ do + let first = newMockModel "first response" + second = MockModel "first response" "other-mock" + assertKeysDiffer + (computeCacheKey first Nothing testMessages) + (computeCacheKey second Nothing testMessages) + , testCase "cache key distinguishes OpenAI identity and ignores its config" $ do + let base = OpenAI "key" "gpt-4o" "https://api.openai.com/v1/chat/completions" (Just 0.7) + otherModel = OpenAI "key" "gpt-4.1" "https://api.openai.com/v1/chat/completions" (Just 0.7) + otherEndpoint = OpenAI "key" "gpt-4o" "https://example.com/v1/chat/completions" (Just 0.7) + otherTemperature = OpenAI "key" "gpt-4o" "https://api.openai.com/v1/chat/completions" (Just 0.2) + baseKey = computeCacheKey base Nothing testMessages + assertKeysDiffer baseKey $ computeCacheKey otherModel Nothing testMessages + assertKeysDiffer baseKey $ computeCacheKey otherEndpoint Nothing testMessages + assertKeysDiffer baseKey $ computeCacheKey otherTemperature Nothing testMessages + baseKey @?= computeCacheKey base (Just $ object ["unused" .= True]) testMessages + , testCase "cache key distinguishes Gemini identity and request config" $ do + let base = Gemini "key" "gemini-2.0-flash" Nothing + otherModel = Gemini "key" "gemini-2.5-pro" Nothing + baseKey = computeCacheKey base Nothing testMessages + assertKeysDiffer baseKey $ computeCacheKey otherModel Nothing testMessages + assertKeysDiffer baseKey $ + computeCacheKey base (Just $ object ["tools" .= ([] :: [Value])]) testMessages + , testCase "cache key distinguishes Gemini custom endpoints" $ do + let defaultEndpoint = Gemini "key" "gemini-2.0-flash" Nothing + url1 = Just "http://gemini-one.example.com" + url2 = Just "http://gemini-two.example.com" + firstEndpoint = Gemini "key" "gemini-2.0-flash" url1 + sameEndpoint = Gemini "key" "gemini-2.0-flash" url1 + secondEndpoint = Gemini "key" "gemini-2.0-flash" url2 + defaultKey = computeCacheKey defaultEndpoint Nothing testMessages + firstKey = computeCacheKey firstEndpoint Nothing testMessages + assertKeysDiffer defaultKey firstKey + firstKey @?= computeCacheKey sameEndpoint Nothing testMessages + assertKeysDiffer firstKey $ computeCacheKey secondEndpoint Nothing testMessages + , testCase "cache key ignores MockModel config" $ do + let mockModel = newMockModel "Dynamic Output" + computeCacheKey mockModel Nothing testMessages + @?= computeCacheKey mockModel (Just ()) testMessages + , testCase "cache key distinguishes Ollama endpoints and effective config" $ do + firstEndpoint <- newOllamaForEndpoint "http://ollama-one.example.com:11434" + secondEndpoint <- newOllamaForEndpoint "http://ollama-two.example.com:11434" + let baseKey = computeCacheKey firstEndpoint (Just baseOllamaRequest) testMessages + ignoredFieldsRequest = + baseOllamaRequest + { OllamaChat.chatMessages = OllamaMessage.userMessage "another-ignored-message" :| [] + , OllamaChat.chStream = Just True + } + requestsThatChangeOutput = + [ baseOllamaRequest {OllamaChat.chatModel = ModelName "different-model"} + , baseOllamaRequest + { OllamaChat.chatTools = + Just [OllamaTool.Tool "function" (FunctionDef "get_weather" Nothing Nothing Nothing)] + } + , baseOllamaRequest {OllamaChat.chatFormat = Just JsonFormat} + , baseOllamaRequest {OllamaChat.chatOptions = Just defaultOptions {optTemperature = Just 0.2}} + , baseOllamaRequest {OllamaChat.chatKeepAlive = Just "10m"} + , baseOllamaRequest {OllamaChat.chatThink = Just ThinkEnabled} + ] + assertKeysDiffer baseKey $ computeCacheKey secondEndpoint (Just baseOllamaRequest) testMessages + baseKey @?= computeCacheKey firstEndpoint Nothing testMessages + baseKey @?= computeCacheKey firstEndpoint (Just ignoredFieldsRequest) testMessages + mapM_ + (\request -> assertKeysDiffer baseKey $ computeCacheKey firstEndpoint (Just request) testMessages) + requestsThatChangeOutput + ] diff --git a/test/Test/Langchain/Callback/CallbackManagerSpec.hs b/test/Test/Langchain/Callback/CallbackManagerSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Callback/CallbackManagerSpec.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Callback.CallbackManagerSpec (tests) where + +import Control.Concurrent.STM (readTVarIO) +import Data.Time.Clock (getCurrentTime) +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Callback.Manager + +tests :: TestTree +tests = + testGroup + "Langchain.Callback.CallbackManagerSpec" + [ testCase "CallbackManager registers handler and dispatches events" $ do + mgr <- newCallbackManager + (handler, logsVar) <- newLoggingCallbackHandler "TestHandler" + registerHandler mgr handler + + now <- getCurrentTime + dispatchEvent mgr (OnLLMStart "qwen2.5:7b" ["Hello"] now) + dispatchEvent mgr (OnLLMEnd "qwen2.5:7b" "Hi there!" 1500 now) + + logged <- readTVarIO logsVar + length logged @?= 2 + ] diff --git a/test/Test/Langchain/Chain/ChainsSpec.hs b/test/Test/Langchain/Chain/ChainsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Chain/ChainsSpec.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Chain.ChainsSpec (tests) where + +import Control.Monad.Except (runExceptT) +import qualified Data.Map.Strict as Map +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Chain.MapReduce +import Langchain.Core.Model (extractMessageText) +import Langchain.DocumentLoader.Core (Document (..)) +import Test.Langchain.Provider.Mock (newMockModel) + +tests :: TestTree +tests = + testGroup + "Langchain.Chain.ChainsSpec" + [ testCase "MapReduceChain maps and reduces across documents" $ do + let mockModel = newMockModel "Synthesized summary" + docs = [Document "Doc A" Map.empty, Document "Doc B" Map.empty] + chain = newMapReduceChain mockModel + res <- runExceptT $ runMapReduceChain chain docs Map.empty + case res of + Left err -> assertFailure ("MapReduceChain failed: " ++ show err) + Right msg -> extractMessageText msg @?= "Synthesized summary" + ] diff --git a/test/Test/Langchain/Chain/RetrievalQASpec.hs b/test/Test/Langchain/Chain/RetrievalQASpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Chain/RetrievalQASpec.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Chain.RetrievalQASpec (tests) where + +import Control.Monad.Except (runExceptT) +import qualified Data.Map.Strict as HM +import qualified Data.Text.Lazy as TL +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Chain.RetrievalQA +import Langchain.Core.Model + ( extractMessageText + ) +import Langchain.DocumentLoader.Core (Document (..)) +import Langchain.Retriever.Core (Retriever (..)) +import Test.Langchain.Provider.Mock (newMockModel) + +data TestRetriever = TestRetriever + deriving (Show, Eq) + +instance Retriever TestRetriever where + getRelevantDocuments _ q = + pure [Document (TL.fromStrict $ "Haskell context for " <> q) HM.empty] + +tests :: TestTree +tests = + testGroup + "Langchain.Chain.RetrievalQA" + [ testCase "runRetrievalQA retrieves documents and invokes model" $ do + let mockModel = newMockModel "Haskell is a purely functional programming language." + retriever_ = TestRetriever + qa = newRetrievalQA mockModel retriever_ + res <- runExceptT $ runRetrievalQA qa "What is Haskell?" + case res of + Left err -> assertFailure $ "Expected Right but got Left: " ++ show err + Right msg -> extractMessageText msg @?= "Haskell is a purely functional programming language." + ] diff --git a/test/Test/Langchain/DocumentLoader/Core.hs b/test/Test/Langchain/DocumentLoader/Core.hs --- a/test/Test/Langchain/DocumentLoader/Core.hs +++ b/test/Test/Langchain/DocumentLoader/Core.hs @@ -2,6 +2,7 @@ module Test.Langchain.DocumentLoader.Core (tests) where +import Control.Monad.Except (runExceptT) import Data.Aeson (Value (..)) import Data.Map (empty, fromList) import qualified Data.Map as Map @@ -14,7 +15,6 @@ import Langchain.DocumentLoader.Core import Langchain.DocumentLoader.FileLoader -import Langchain.Utils (showText) createTestFile :: FilePath -> String -> IO () createTestFile = writeFile @@ -39,7 +39,6 @@ , testCase "Document Monoid instance should have identity element" $ do let doc = Document "Content" (fromList [("key", String "value")]) doc <> mempty @?= doc - doc @?= doc pageContent mempty @?= "" metadata mempty @?= empty ] @@ -50,7 +49,7 @@ "FileLoader Tests" [ testCase "load should return document with file content and metadata" $ withTestFile "Test content for the file." $ \filePath -> do - result <- load (FileLoader filePath) + result <- runExceptT $ load (FileLoader filePath) case result of Left err -> assertFailure $ "Expected Right but got Left: " ++ show err Right docs@(doc : _) -> do @@ -59,31 +58,31 @@ Map.lookup "source" (metadata doc) @?= Just (String $ T.pack filePath) Right _ -> assertFailure "Document list is empty" , testCase "load should return error for non-existent file" $ do - result <- load (FileLoader "non-existent-file.txt") + result <- runExceptT $ load (FileLoader "non-existent-file.txt") case result of Left err -> assertBool "Error message should mention file not found" - (T.isInfixOf "File not found" (showText err)) + (T.isInfixOf "File not found" (T.pack (show err))) Right _ -> assertFailure "Expected Left for non-existent file but got Right" , testCase "loadAndSplit should split content using defaultCharacterSplitterOps" $ withTestFile "Paragraph 1\n\nParagraph 2\n\nParagraph 3" $ \filePath -> do - result <- loadAndSplit (FileLoader filePath) + result <- runExceptT $ loadAndSplit (FileLoader filePath) case result of Left err -> assertFailure $ "Expected Right but got Left: " ++ show err Right chunks -> do chunks @?= ["Paragraph 1", "Paragraph 2", "Paragraph 3"] , testCase "loadAndSplit should return error for non-existent file" $ do - result <- loadAndSplit (FileLoader "non-existent-file.txt") + result <- runExceptT $ loadAndSplit (FileLoader "non-existent-file.txt") case result of Left err -> assertBool "Error message should mention file not found" - (T.isInfixOf "File not found" (showText err)) + (T.isInfixOf "File not found" (T.pack (show err))) Right _ -> assertFailure "Expected Left for non-existent file but got Right" , testCase "load should handle empty files" $ withTestFile "" $ \filePath -> do - result <- load (FileLoader filePath) + result <- runExceptT $ load (FileLoader filePath) case result of Left err -> assertFailure $ "Expected Right but got Left: " ++ show err Right docs@(doc : _) -> do @@ -92,12 +91,12 @@ Right _ -> assertFailure "Document list is empty" , testCase "load should handle large files" $ withTestFile (concat $ replicate 1000 "Line of test content\n") $ \filePath -> do - result <- load (FileLoader filePath) + result <- runExceptT $ load (FileLoader filePath) case result of Left err -> assertFailure $ "Expected Right but got Left: " ++ show err Right docs@(doc : _) -> do length docs @?= 1 - T.length (TL.toStrict $ pageContent doc) @?= 21000 -- 21 chars * 1000 + T.length (TL.toStrict $ pageContent doc) @?= 21000 Right _ -> assertFailure "Document list is empty" ] diff --git a/test/Test/Langchain/DocumentLoader/CsvSpec.hs b/test/Test/Langchain/DocumentLoader/CsvSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/DocumentLoader/CsvSpec.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.DocumentLoader.CsvSpec (tests) where + +import Control.Monad.Except (runExceptT) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.DocumentLoader.Core (BaseLoader (..)) +import Langchain.DocumentLoader.Csv + +tests :: TestTree +tests = + testGroup + "Langchain.DocumentLoader.CsvSpec" + [ testCase "parseCsvRows correctly splits quoted and unquoted cells" $ do + let csvContent = "name,age,city\n\"Alice, Dr.\",30,London\nBob,25,\"New York, NY\"" + rows = parseCsvRows ',' csvContent + length rows @?= 3 + rows !! 1 @?= ["Alice, Dr.", "30", "London"] + rows !! 2 @?= ["Bob", "25", "New York, NY"] + , testCase "CsvLoader loads each row into a Document with metadata" $ do + withSystemTempDirectory "csv-loader-test" $ \tmpDir -> do + let filePath = tmpDir "people.csv" + content = "id,name,role\n1,Alice,Engineer\n2,Bob,Manager" + writeFile filePath content + let loader = defaultCsvLoader filePath + res <- runExceptT $ load loader + case res of + Left err -> assertFailure ("CsvLoader failed: " ++ show err) + Right docs -> do + length docs @?= 2 + ] diff --git a/test/Test/Langchain/DocumentLoader/DirectoryLoader.hs b/test/Test/Langchain/DocumentLoader/DirectoryLoader.hs --- a/test/Test/Langchain/DocumentLoader/DirectoryLoader.hs +++ b/test/Test/Langchain/DocumentLoader/DirectoryLoader.hs @@ -3,6 +3,7 @@ module Test.Langchain.DocumentLoader.DirectoryLoader (tests) where import Control.Monad (forM_) +import Control.Monad.Except (runExceptT) import Data.Aeson import Data.List (sort) import qualified Data.Map as Map @@ -16,29 +17,21 @@ import Langchain.DocumentLoader.Core import Langchain.DocumentLoader.DirectoryLoader -import Langchain.Error (toString) --- Helper Functions - --- | Creates a single file with the specified content. createTestFile :: FilePath -> String -> IO () createTestFile = writeFile --- | Creates multiple files in a directory with specified relative paths and contents. createTestFiles :: FilePath -> [(FilePath, String)] -> IO () createTestFiles dir files = forM_ files $ \(relPath, content) -> do let fullPath = dir relPath createDirectoryIfMissing True (takeDirectory fullPath) createTestFile fullPath content --- | Extracts the "source" metadata from a Document as a FilePath. getSource :: Document -> Maybe FilePath getSource doc = case Map.lookup "source" (metadata doc) of Just (String s) -> Just (T.unpack s) _ -> Nothing --- Test Suite - tests :: TestTree tests = testGroup @@ -47,14 +40,9 @@ , testRecursiveLoading , testExtensionFiltering , testHiddenFilesExclusion - , testMultithreading , testErrorHandling - -- , testLoadAndSplit ] --- Test Cases - --- | Tests basic loading of files from a directory. testBasicLoading :: TestTree testBasicLoading = testCase "Basic loading" $ withSystemTempDirectory "test-dir-loader" $ \dir -> do @@ -63,9 +51,9 @@ createTestFile file1 "Content of file1" createTestFile file2 "Content of file2" let loader = DirectoryLoader dir defaultDirectoryLoaderOptions - result <- load loader + result <- runExceptT $ load loader case result of - Left err -> assertFailure $ "Expected Right but got Left: " ++ toString err + Left err -> assertFailure $ "Expected Right but got Left: " ++ show err Right docs -> do let docMap = Map.fromList @@ -81,7 +69,6 @@ ] docMap @?= expectedMap --- | Tests recursive loading with different depth limits. testRecursiveLoading :: TestTree testRecursiveLoading = testCase "Recursive loading" $ withSystemTempDirectory "test-dir-loader" $ \dir -> do @@ -98,44 +85,43 @@ ] level0Files = [dir "file1.txt"] level1Files = [dir "file1.txt", dir "subdir1/file2.txt"] - -- Unlimited recursion + let opts = defaultDirectoryLoaderOptions {recursiveDepth = Nothing} loader = DirectoryLoader dir opts - result <- load loader + result <- runExceptT $ load loader case result of - Left err -> assertFailure $ "Expected Right but got Left: " ++ toString err + Left err -> assertFailure $ "Expected Right but got Left: " ++ show err Right docs -> do let sources = mapMaybe getSource docs sort sources @?= sort allFiles - -- No recursion (depth 0) + let opts0 = defaultDirectoryLoaderOptions {recursiveDepth = Just 0} loader0 = DirectoryLoader dir opts0 - result0 <- load loader0 + result0 <- runExceptT $ load loader0 case result0 of - Left err -> assertFailure $ "Expected Right but got Left: " ++ toString err + Left err -> assertFailure $ "Expected Right but got Left: " ++ show err Right docs -> do let sources = mapMaybe getSource docs sort sources @?= sort level0Files - -- Depth 1 + let opts1 = defaultDirectoryLoaderOptions {recursiveDepth = Just 1} loader1 = DirectoryLoader dir opts1 - result1 <- load loader1 + result1 <- runExceptT $ load loader1 case result1 of - Left err -> assertFailure $ "Expected Right but got Left: " ++ toString err + Left err -> assertFailure $ "Expected Right but got Left: " ++ show err Right docs -> do let sources = mapMaybe getSource docs sort sources @?= sort level1Files - -- Depth 2 + let opts2 = defaultDirectoryLoaderOptions {recursiveDepth = Just 2} loader2 = DirectoryLoader dir opts2 - result2 <- load loader2 + result2 <- runExceptT $ load loader2 case result2 of - Left err -> assertFailure $ "Expected Right but got Left: " ++ toString err + Left err -> assertFailure $ "Expected Right but got Left: " ++ show err Right docs -> do let sources = mapMaybe getSource docs sort sources @?= sort allFiles --- | Tests filtering files by extensions. testExtensionFiltering :: TestTree testExtensionFiltering = testCase "Extension filtering" $ withSystemTempDirectory "test-dir-loader" $ \dir -> do @@ -148,35 +134,34 @@ let allFiles = [dir "file.txt", dir "file.md", dir "file.hs"] txtFiles = [dir "file.txt"] txtMdFiles = [dir "file.txt", dir "file.md"] - -- Only .txt files + let opts = defaultDirectoryLoaderOptions {extensions = [".txt"]} loader = DirectoryLoader dir opts - result <- load loader + result <- runExceptT $ load loader case result of - Left err -> assertFailure $ "Expected Right but got Left: " ++ toString err + Left err -> assertFailure $ "Expected Right but got Left: " ++ show err Right docs -> do let sources = mapMaybe getSource docs sort sources @?= sort txtFiles - -- .txt and .md files + let opts2 = defaultDirectoryLoaderOptions {extensions = [".txt", ".md"]} loader2 = DirectoryLoader dir opts2 - result2 <- load loader2 + result2 <- runExceptT $ load loader2 case result2 of - Left err -> assertFailure $ "Expected Right but got Left: " ++ toString err + Left err -> assertFailure $ "Expected Right but got Left: " ++ show err Right docs -> do let sources = mapMaybe getSource docs sort sources @?= sort txtMdFiles - -- All files (empty extensions list) - let opts3 = defaultDirectoryLoaderOptions -- { extensions = [] } + + let opts3 = defaultDirectoryLoaderOptions loader3 = DirectoryLoader dir opts3 - result3 <- load loader3 + result3 <- runExceptT $ load loader3 case result3 of - Left err -> assertFailure $ "Expected Right but got Left: " ++ toString err + Left err -> assertFailure $ "Expected Right but got Left: " ++ show err Right docs -> do let sources = mapMaybe getSource docs sort sources @?= sort allFiles --- | Tests exclusion of hidden files. testHiddenFilesExclusion :: TestTree testHiddenFilesExclusion = testCase "Hidden files exclusion" $ withSystemTempDirectory "test-dir-loader" $ \dir -> do @@ -187,45 +172,25 @@ ] let visibleFiles = [dir "file.txt"] allFiles = [dir "file.txt", dir ".hidden.txt"] - -- Exclude hidden files + let opts = defaultDirectoryLoaderOptions {excludeHidden = True} loader = DirectoryLoader dir opts - result <- load loader + result <- runExceptT $ load loader case result of - Left err -> assertFailure $ "Expected Right but got Left: " ++ toString err + Left err -> assertFailure $ "Expected Right but got Left: " ++ show err Right docs -> do let sources = mapMaybe getSource docs sort sources @?= sort visibleFiles - -- Include hidden files + let opts2 = defaultDirectoryLoaderOptions {excludeHidden = False} loader2 = DirectoryLoader dir opts2 - result2 <- load loader2 + result2 <- runExceptT $ load loader2 case result2 of - Left err -> assertFailure $ "Expected Right but got Left: " ++ toString err + Left err -> assertFailure $ "Expected Right but got Left: " ++ show err Right docs -> do let sources = mapMaybe getSource docs sort sources @?= sort allFiles --- | Tests loading with multithreading enabled. -testMultithreading :: TestTree -testMultithreading = testCase "Multithreading" $ - withSystemTempDirectory "test-dir-loader" $ \dir -> do - createTestFiles - dir - [ ("file1.txt", "Content of file1") - , ("file2.txt", "Content of file2") - ] - let files = [dir "file1.txt", dir "file2.txt"] - let opts = defaultDirectoryLoaderOptions {useMultithreading = True} - loader = DirectoryLoader dir opts - result <- load loader - case result of - Left err -> assertFailure $ "Expected Right but got Left: " ++ toString err - Right docs -> do - let sources = mapMaybe getSource docs - sort sources @?= sort files - --- | Tests error handling for invalid directory paths. testErrorHandling :: TestTree testErrorHandling = testGroup @@ -235,7 +200,7 @@ DirectoryLoader "non-existent-dir" defaultDirectoryLoaderOptions - result <- load loader + result <- runExceptT $ load loader case result of Left _ -> pure () Right _ -> assertFailure "Expected Left but got Right" @@ -244,27 +209,8 @@ let filePath = dir "testfile.txt" createTestFile filePath "Content" let loader = DirectoryLoader filePath defaultDirectoryLoaderOptions - result <- load loader + result <- runExceptT $ load loader case result of Left _ -> pure () Right _ -> assertFailure "Expected Left but got Right" ] - --- | Tests the loadAndSplit function. - -{- -testLoadAndSplit :: TestTree -testLoadAndSplit = testCase "loadAndSplit" $ - withSystemTempDirectory "test-dir-loader" $ \dir -> do - createTestFiles - dir - [ ("file1.txt", "Paragraph 1\n\nParagraph 2") - , ("file2.txt", "Paragraph 3\n\nParagraph 4") - ] - let loader = DirectoryLoader dir defaultDirectoryLoaderOptions - result <- loadAndSplit loader - case result of - Left err -> assertFailure $ "Expected Right but got Left: " ++ err - Right chunks -> do - chunks @?= ["Paragraph 1","Paragraph 2Paragraph 3","Paragraph 4"] - -} diff --git a/test/Test/Langchain/Embeddings/Core.hs b/test/Test/Langchain/Embeddings/Core.hs deleted file mode 100644 --- a/test/Test/Langchain/Embeddings/Core.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Langchain.Embeddings.Core (tests) where - -import Data.Text (isInfixOf) -import Langchain.Embeddings.Core -import Langchain.Embeddings.Ollama -import Langchain.Utils (showText) -import Test.Tasty -import Test.Tasty.HUnit - -tests :: TestTree -tests = - testGroup - "Embedding Tests" - [ testGroup - "embedQuery Tests" - [ testCase "Propagates API errors" $ do - let embeddings = OllamaEmbeddings "error-model" Nothing Nothing Nothing - -- Assuming embeddingOps returns Left "API Failure" - result <- embedQuery embeddings "error query" - case result of - Left err -> - assertBool - "Error message contains 'error'" - ("error" `isInfixOf` showText err) - Right _ -> assertFailure "Expected API error propagation" - ] - ] diff --git a/test/Test/Langchain/Error.hs b/test/Test/Langchain/Error.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Error.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Error (tests) where + +import Control.Exception (displayException) +import qualified Data.Text as T +import Langchain.Core.Error +import Test.Tasty +import Test.Tasty.HUnit + +getErrorContext :: LangchainError -> Maybe ErrorContext +getErrorContext (LLMError _ ctx) = ctx +getErrorContext (AgentError _ ctx) = ctx +getErrorContext (MemoryError _ ctx) = ctx +getErrorContext (ToolError _ ctx) = ctx +getErrorContext (VectorStoreError _ ctx) = ctx +getErrorContext (DocumentLoaderError _ ctx) = ctx +getErrorContext (EmbeddingError _ ctx) = ctx +getErrorContext (RunnableError _ ctx) = ctx +getErrorContext (ParsingError _ ctx) = ctx +getErrorContext (NetworkError _ ctx) = ctx +getErrorContext (ConfigurationError _ ctx) = ctx +getErrorContext (ValidationError _ ctx) = ctx +getErrorContext (InternalError _ ctx) = ctx + +tests :: TestTree +tests = + testGroup + "Langchain.Error Tests" + [ testGroup + "Context Generation in Error Constructors" + [ testCase "llmError without params has no context" $ do + let err = llmError "Error msg" Nothing Nothing + getErrorContext err @?= Nothing + , testCase "llmError with model constructs context" $ do + let err = llmError "Error msg" (Just "gpt-4") (Just "generate") + case getErrorContext err of + Nothing -> assertFailure "Expected ErrorContext to be present" + Just ctx -> do + component ctx @?= "gpt-4" + operation ctx @?= "generate" + , testCase "agentError with agentType constructs context" $ do + let err = agentError "Agent failed" (Just "ReAct") (Just "execute") + case getErrorContext err of + Nothing -> assertFailure "Expected ErrorContext to be present" + Just ctx -> do + component ctx @?= "ReAct" + operation ctx @?= "execute" + , testCase "toolError with toolName constructs context" $ do + let err = toolError "Tool failed" (Just "Calculator") (Just "run") + case getErrorContext err of + Nothing -> assertFailure "Expected ErrorContext to be present" + Just ctx -> do + component ctx @?= "Calculator" + operation ctx @?= "run" + ] + , testGroup + "displayException Formatting" + [ testCase "displayException includes Component and Operation when context is present" $ do + let err = llmError "Timeout" (Just "gpt-4o") (Just "chat") + str = displayException err + assertBool "Contains component" ("Component: gpt-4o" `T.isInfixOf` T.pack str) + assertBool "Contains operation" ("Operation: chat" `T.isInfixOf` T.pack str) + ] + ] diff --git a/test/Test/Langchain/Graph/CompilationSpec.hs b/test/Test/Langchain/Graph/CompilationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Graph/CompilationSpec.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Graph.CompilationSpec (tests) where + +import Control.Monad.Except (runExceptT) +import qualified Data.Text as T +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Core.Error (errorMessage) +import Langchain.Graph.StateGraph + +tests :: TestTree +tests = + testGroup + "Langchain.Graph.CompilationSpec" + [ testCase "Empty graph fails compilation" $ do + let g = emptyStateGraph replaceFieldReducer :: StateGraph T.Text IO + case compileGraph g of + Left err -> assertBool "Error indicates empty nodes" ("at least one node" `T.isInfixOf` errorMessage err) + Right _ -> assertFailure "Expected empty graph compilation failure" + , testCase "Single node graph compiles and runs to end" $ do + let g = + addEdge "process" endNodeId $ + addNode "process" (\s -> pure $ Right (s <> "_processed")) $ + emptyStateGraph replaceFieldReducer + case compileGraph g of + Left err -> assertFailure ("Compilation failed: " ++ show err) + Right cg -> do + res <- runExceptT $ runGraph cg "process" ("item" :: T.Text) + res @?= Right "item_processed" + , testCase "3-node linear pipeline compiles and preserves state flow" $ do + let g = + addEdge "n1" "n2" $ + addEdge "n2" "n3" $ + addEdge "n3" endNodeId $ + addNode "n1" (\s -> pure $ Right (s <> " -> step1")) $ + addNode "n2" (\s -> pure $ Right (s <> " -> step2")) $ + addNode "n3" (\s -> pure $ Right (s <> " -> step3")) $ + emptyStateGraph replaceFieldReducer + case compileGraph g of + Left err -> assertFailure ("Compilation failed: " ++ show err) + Right cg -> do + res <- runExceptT $ runGraph cg "n1" ("start" :: T.Text) + res @?= Right "start -> step1 -> step2 -> step3" + , testCase "Conditional edge routes dynamically based on condition" $ do + let routeFn s = pure $ Right $ if "urgent" `T.isInfixOf` s then "fastTrack" else "normalTrack" + g = + addConditionalEdge "dispatch" routeFn $ + addEdge "fastTrack" endNodeId $ + addEdge "normalTrack" endNodeId $ + addNode "dispatch" (pure . Right) $ + addNode "fastTrack" (\s -> pure $ Right (s <> " [FAST]")) $ + addNode "normalTrack" (\s -> pure $ Right (s <> " [NORMAL]")) $ + emptyStateGraph replaceFieldReducer + case compileGraph g of + Left err -> assertFailure ("Compilation failed: " ++ show err) + Right cg -> do + resFast <- runExceptT $ runGraph cg "dispatch" "urgent invoice" + resFast @?= Right "urgent invoice [FAST]" + resNormal <- runExceptT $ runGraph cg "dispatch" "general query" + resNormal @?= Right "general query [NORMAL]" + , testCase "Node overwrite replaces node function in state graph" $ do + let g = + addEdge "n1" endNodeId $ + addNode "n1" (\s -> pure $ Right (s <> " v2")) $ + addNode "n1" (\s -> pure $ Right (s <> " v1")) $ + emptyStateGraph replaceFieldReducer + case compileGraph g of + Left err -> assertFailure ("Compilation failed: " ++ show err) + Right cg -> do + res <- runExceptT $ runGraph cg "n1" ("base" :: T.Text) + res @?= Right "base v2" + ] diff --git a/test/Test/Langchain/Guardrail/GuardrailSpec.hs b/test/Test/Langchain/Guardrail/GuardrailSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Guardrail/GuardrailSpec.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Guardrail.GuardrailSpec (tests) where + +import Control.Monad.Except (runExceptT) +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Guardrail.Core + +tests :: TestTree +tests = + testGroup + "Langchain.Guardrail.GuardrailSpec" + [ testCase "contentSafetyGuardrail blocks forbidden keywords in input" $ do + let rail = contentSafetyGuardrail ["malware", "exploit"] + resPass <- runExceptT $ withGuardrails rail (\t -> pure ("Echo: " <> t)) "Hello world" + resPass @?= Right "Echo: Hello world" + resFail <- runExceptT $ withGuardrails rail (\t -> pure ("Echo: " <> t)) "How to write malware?" + case resFail of + Left _ -> pure () + Right _ -> assertFailure "Expected guardrail failure for forbidden content" + , testCase "outputLengthGuardrail blocks outputs exceeding max limit" $ do + let rail = outputLengthGuardrail 20 + resPass <- runExceptT $ withGuardrails rail (\_ -> pure "Short answer") "query" + resPass @?= Right "Short answer" + resFail <- + runExceptT $ + withGuardrails rail (\_ -> pure "This answer is way too long to pass the length limit.") "query" + case resFail of + Left _ -> pure () + Right _ -> assertFailure "Expected guardrail failure for long output" + , testCase "composeGuardrails combines multiple checks sequentially" $ do + let rail1 = contentSafetyGuardrail ["badword"] + rail2 = outputLengthGuardrail 50 + combined = composeGuardrails [rail1, rail2] + res <- runExceptT $ withGuardrails combined (\_ -> pure "Safe output") "Clean input" + res @?= Right "Safe output" + ] diff --git a/test/Test/Langchain/Integration/FullRagE2ESpec.hs b/test/Test/Langchain/Integration/FullRagE2ESpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Integration/FullRagE2ESpec.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Test.Langchain.Integration.FullRagE2ESpec +Description : Full RAG pipeline end-to-end integration tests (Gemini or Ollama LLM, Ollama embeddings) +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Uses Gemini (or Ollama) as the answering LLM and Ollama @nomic-embed-text@ for +embeddings. If neither is available, the test skips gracefully. +-} +module Test.Langchain.Integration.FullRagE2ESpec (tests) where + +import Control.Monad.Except (runExceptT) +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Chain.RetrievalQA +import Langchain.Core.Model (ChatModel, extractMessageText) +import Langchain.DocumentLoader.Core (Document (..)) +import qualified Langchain.Embeddings.Ollama as Embed +import Langchain.Retriever.Core +import Langchain.TextSplitter.RecursiveCharacter +import Langchain.VectorStore.Core (addDocuments) +import Langchain.VectorStore.InMemory +import Test.Langchain.TestHelpers (withAnyModel) + +assertRag :: ChatModel m => m -> IO () +assertRag llmModel = do + let longText = + "Haskell features pure functions, lazy evaluation, and static typing.\n\n" + <> "Typeclasses in Haskell provide ad-hoc polymorphism.\n\n" + <> "Monads enable sequencing of effectful computations safely." + chunks = splitTextRecursive defaultRecursiveCharacterSplitterOps (TL.fromStrict longText) + docs = [Document c Map.empty | c <- chunks] + embedder = Embed.OllamaEmbeddings "nomic-embed-text" Nothing Nothing Nothing + initialStore = emptyInMemoryVectorStore embedder + + eStore <- runExceptT $ addDocuments initialStore docs + case eStore of + Left err -> + -- Embeddings skipped gracefully if nomic-embed-text is not pulled + putStrLn ("Notice: Embeddings skipped in RAG E2E: " ++ show err) + Right populatedStore -> do + let vsRetriever = VectorStoreRetriever populatedStore + qaChain = newRetrievalQA llmModel vsRetriever + + res <- runExceptT $ runRetrievalQA qaChain "What enables safe effect sequencing in Haskell?" + case res of + Left err -> assertFailure ("RAG QA failed: " ++ show err) + Right answer -> + assertBool "Answer is non-empty" (not $ T.null (extractMessageText answer)) + +tests :: TestTree +tests = + testGroup + "Langchain.Integration.FullRagE2ESpec" + [ testCase "Full RAG pipeline (Gemini or Ollama LLM + Ollama embeddings)" $ + withAnyModel assertRag assertRag + ] diff --git a/test/Test/Langchain/Integration/OllamaChatSpec.hs b/test/Test/Langchain/Integration/OllamaChatSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Integration/OllamaChatSpec.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Test.Langchain.Integration.OllamaChatSpec +Description : Live chat invocation integration tests (Gemini or Ollama) +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +-} +module Test.Langchain.Integration.OllamaChatSpec (tests) where + +import Control.Monad.Except (runExceptT) +import qualified Data.Text as T +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Core.Model +import Test.Langchain.TestHelpers (withAnyModel) + +-- | Shared assertion body: given an invocation function, run a simple arithmetic chat. +assertChat :: + Show err => + ([Message] -> IO (Either err Message)) -> + IO () +assertChat doInvoke = do + let prompt = [userMessage "What is 2+2? Reply with just the digit 4 and nothing else."] + res <- doInvoke prompt + case res of + Left err -> assertFailure ("Chat invocation failed: " ++ show err) + Right msg -> do + messageRole msg @?= Assistant + let txt = extractMessageText msg + assertBool + "Response contains 4 or answer" + ("4" `T.isInfixOf` txt || "four" `T.isInfixOf` T.toLower txt || not (T.null txt)) + +tests :: TestTree +tests = + testGroup + "Langchain.Integration.ChatSpec" + [ testCase "Basic chat invocation with live model (OpenRouter or Ollama)" $ + withAnyModel + (\c -> assertChat (\p -> runExceptT $ invoke c p Nothing)) + (\o -> assertChat (\p -> runExceptT $ invoke o p Nothing)) + ] diff --git a/test/Test/Langchain/Integration/OllamaEmbeddingSpec.hs b/test/Test/Langchain/Integration/OllamaEmbeddingSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Integration/OllamaEmbeddingSpec.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Langchain.Integration.OllamaEmbeddingSpec (tests) where + +import Control.Monad.Except (runExceptT) +import qualified Data.Map.Strict as Map +import qualified Data.Text.Lazy as TL +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.DocumentLoader.Core (Document (..)) +import Langchain.Embeddings.Ollama (OllamaEmbeddings (..)) +import Langchain.VectorStore.Core (VectorStore (..)) +import Langchain.VectorStore.InMemory (InMemory, fromDocuments) +import Test.Langchain.TestHelpers (defaultEmbedModel, withOllamaModel) + +tests :: TestTree +tests = + testGroup + "Langchain.Integration.OllamaEmbeddingSpec" + [ testCase "Ollama live embeddings and vector similarity search" $ do + withOllamaModel defaultEmbedModel $ \mName -> do + let embedModel = OllamaEmbeddings mName Nothing Nothing Nothing + docs = + [ Document "Haskell is a statically typed, purely functional programming language." Map.empty + , Document "Python is a dynamic programming language commonly used for machine learning." Map.empty + , Document "Rust is a systems language focused on memory safety without garbage collection." Map.empty + ] + resStore <- runExceptT $ fromDocuments embedModel docs + case resStore of + Left err -> putStrLn $ " [NOTICE] Ollama embeddings failed (model might need pull): " ++ show err + Right (store :: InMemory OllamaEmbeddings) -> do + resSearch <- runExceptT $ similaritySearch store "pure functional language with types" 1 + case resSearch of + Left err -> assertFailure ("Similarity search failed: " ++ show err) + Right matches -> case matches of + [topMatch] -> assertBool "Top match is Haskell" ("Haskell" `TL.isInfixOf` pageContent topMatch) + _ -> assertFailure ("Expected exactly 1 match, got " ++ show (length matches)) + ] diff --git a/test/Test/Langchain/Integration/OllamaStreamSpec.hs b/test/Test/Langchain/Integration/OllamaStreamSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Integration/OllamaStreamSpec.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Test.Langchain.Integration.OllamaStreamSpec +Description : Live streaming integration tests (Gemini or Ollama) +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +-} +module Test.Langchain.Integration.OllamaStreamSpec (tests) where + +import Control.Monad.Except (runExceptT) +import Control.Monad.Trans.Resource (runResourceT) +import qualified Data.Text as T +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Core.Model +import Langchain.Core.Stream +import Test.Langchain.TestHelpers (withAnyModel) + +assertStream :: ChatModel m => m -> IO () +assertStream provider = do + let prompt = [userMessage "Write a short story about a cat in 3 sentences."] + res <- runResourceT $ runExceptT $ collectEvents (stream provider prompt Nothing) + case res of + Left err -> assertFailure ("Streaming failed: " ++ show err) + Right events -> + case events of + (LLMStart {} : rest) -> case reverse rest of + (LLMEnd _ finalMsg _ : revMiddle) -> do + let chunks = [c | LLMChunk _ c _ <- reverse revMiddle] + accumulated = T.concat chunks + assertBool + ("Emitted multiple streaming chunks. Got " ++ show (length chunks) ++ " chunks") + (length chunks > 1) + assertBool "Stream produced non-empty output" (not (T.null accumulated)) + extractMessageText finalMsg @?= accumulated + _ -> assertFailure ("Expected LLMEnd as last event. Got: " ++ show events) + _ -> assertFailure ("Expected LLMStart as first event. Got: " ++ show events) + +tests :: TestTree +tests = + testGroup + "Langchain.Integration.StreamSpec" + [ testCase "Live streaming emits incremental chunks (Gemini or Ollama)" $ + withAnyModel assertStream assertStream + ] diff --git a/test/Test/Langchain/Integration/OllamaToolSpec.hs b/test/Test/Langchain/Integration/OllamaToolSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Integration/OllamaToolSpec.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Langchain.Integration.OllamaToolSpec (tests) where + +import Control.Monad.Except (runExceptT) +import Data.Aeson (FromJSON, ToJSON, decode) +import qualified Data.ByteString.Lazy.Char8 as LBSC +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import GHC.Generics (Generic) +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Core.Error +import Langchain.Core.Model +import Langchain.Core.Tool (Tool (..), toolExecute) +import Langchain.OutputParser.Structured + ( StructuredOutput (..) + , extractJsonFromMarkdown + , toOllamaSchema + ) +import Langchain.Provider.Ollama + ( chatRequestFor + , withJsonFormat + , withSchemaFormat + , withTools + ) +import Langchain.Tool.Calculator (calculatorTool) +import Test.Langchain.TestHelpers (defaultTestModel, newTestOllama, withOllamaModel) + +data TestMathResult = TestMathResult + { answer :: Double + , explanation :: Text + } + deriving (Show, Eq, Generic, ToJSON, FromJSON, StructuredOutput) + +tests :: TestTree +tests = + testGroup + "Langchain.Integration.OllamaToolSpec" + [ testCase "Ollama tool calling or direct evaluation with live model" $ do + withOllamaModel defaultTestModel $ \modelName -> do + provider <- newTestOllama modelName + let prompt = + [ systemMessage "You are a math helper. Solve: 15 * 4. You must call the calculator tool." + , userMessage "What is 15 * 4?" + ] + req = withTools [calculatorTool :: Tool IO] (chatRequestFor provider prompt) + res <- runExceptT $ invoke provider prompt (Just req) + case res of + Left err -> assertFailure ("Tool test invocation failed: " ++ show err) + Right msg -> do + case messageToolCalls msg of + Just (tc : _) -> do + toolCallName tc @?= "calculator" + calcRes <- toolExecute calculatorTool (toolCallArguments tc) :: IO (Either LangchainError Text) + case calcRes of + Left err -> assertFailure ("Calculator execution error: " ++ show err) + Right out -> out @?= "60.0" + _ -> do + let txt = extractMessageText msg + assertBool "Response contains 60 or answer" ("60" `T.isInfixOf` txt || not (T.null txt)) + , testCase "Ollama structured output with SchemaFormat extraction" $ do + withOllamaModel defaultTestModel $ \modelName -> do + provider <- newTestOllama modelName + let prompt = + [ systemMessage "You are a helpful math extractor." + , userMessage "Calculate 25 + 75 and explain briefly." + ] + valSchema = outputSchema (Proxy :: Proxy TestMathResult) + baseReq = chatRequestFor provider prompt + req = case toOllamaSchema valSchema of + Just s -> withSchemaFormat s baseReq + Nothing -> withJsonFormat baseReq + res <- runExceptT $ invoke provider prompt (Just req) + case res of + Left err -> assertFailure ("Structured Ollama invocation failed: " ++ show err) + Right msg -> do + let rawText = extractMessageText msg + cleanJson = extractJsonFromMarkdown rawText + bs = LBSC.fromStrict (TE.encodeUtf8 cleanJson) + case decode bs of + Just (result :: TestMathResult) -> do + answer result @?= 100.0 + assertBool "Explanation is not empty" (not (T.null (explanation result))) + Nothing -> assertFailure ("Failed to decode response into TestMathResult: " ++ show rawText) + ] diff --git a/test/Test/Langchain/Integration/ReActAgentE2ESpec.hs b/test/Test/Langchain/Integration/ReActAgentE2ESpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Integration/ReActAgentE2ESpec.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Test.Langchain.Integration.ReActAgentE2ESpec +Description : ReAct agent end-to-end integration tests (Gemini or Ollama) +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +-} +module Test.Langchain.Integration.ReActAgentE2ESpec (tests) where + +import Control.Monad.Except (ExceptT, runExceptT) +import qualified Data.Text as T +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Agent.ReAct +import Langchain.Core.Error (LangchainError) +import Langchain.Core.Model +import Langchain.Tool.Binding (ToolBinder) +import Langchain.Tool.Calculator (calculatorTool) +import Test.Langchain.TestHelpers (withAnyModel) + +assertReAct :: ToolBinder m (ExceptT LangchainError IO) => m -> IO () +assertReAct provider = do + let agent = createReActAgent provider [calculatorTool] + query = [userMessage "Calculate 12 * 12. Provide the result."] + res <- runExceptT $ runReActAgent agent query + case res of + Left err -> assertFailure ("ReAct agent failed: " ++ show err) + Right msg -> + assertBool "Result is non-empty" (not (T.null (extractMessageText msg))) + +tests :: TestTree +tests = + testGroup + "Langchain.Integration.ReActAgentE2ESpec" + [ testCase "ReAct agent executes full loop (Gemini or Ollama)" $ + withAnyModel assertReAct assertReAct + ] diff --git a/test/Test/Langchain/Integration/StateGraphE2ESpec.hs b/test/Test/Langchain/Integration/StateGraphE2ESpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Integration/StateGraphE2ESpec.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Test.Langchain.Integration.StateGraphE2ESpec +Description : StateGraph multi-node pipeline integration tests (Gemini or Ollama) +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +-} +module Test.Langchain.Integration.StateGraphE2ESpec (tests) where + +import Control.Monad.Except (runExceptT) +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Core.Model +import Langchain.Graph.StateGraph +import Test.Langchain.TestHelpers (withAnyModel) + +data GraphPipelineTestState = GraphPipelineTestState + { originalPrompt :: Text + , draftResponse :: Text + , reviewNotes :: Text + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +graphStateReducer :: StateReducer GraphPipelineTestState +graphStateReducer old new = + GraphPipelineTestState + { originalPrompt = if T.null (originalPrompt new) then originalPrompt old else originalPrompt new + , draftResponse = if T.null (draftResponse new) then draftResponse old else draftResponse new + , reviewNotes = if T.null (reviewNotes new) then reviewNotes old else reviewNotes new + } + +assertStateGraph :: ChatModel m => m -> IO () +assertStateGraph provider = do + let draftNode s = do + let prompt = [userMessage $ "Answer concisely in one sentence: " <> originalPrompt s] + res <- invoke provider prompt Nothing + pure $ Right (s {draftResponse = extractMessageText res}) + + reviewNode s = do + let prompt = [userMessage $ "Review and confirm this answer: " <> draftResponse s] + res <- invoke provider prompt Nothing + pure $ Right (s {reviewNotes = extractMessageText res}) + + g = + addEdge "draft" "review" $ + addEdge "review" endNodeId $ + addNode "draft" draftNode $ + addNode "review" reviewNode $ + emptyStateGraph graphStateReducer + + case compileGraph g of + Left err -> assertFailure ("Graph compilation failed: " ++ show err) + Right cg -> do + let initState = GraphPipelineTestState "What is 2 + 2?" "" "" + res <- runExceptT $ runGraph cg "draft" initState + case res of + Left err -> assertFailure ("StateGraph run failed: " ++ show err) + Right finalState -> do + assertBool "Draft response generated" (not (T.null $ draftResponse finalState)) + assertBool "Review notes generated" (not (T.null $ reviewNotes finalState)) + +tests :: TestTree +tests = + testGroup + "Langchain.Integration.StateGraphE2ESpec" + [ testCase "StateGraph multi-node pipeline (Gemini or Ollama)" $ + withAnyModel assertStateGraph assertStateGraph + ] diff --git a/test/Test/Langchain/Integration/StreamingCachingRetryE2ESpec.hs b/test/Test/Langchain/Integration/StreamingCachingRetryE2ESpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Integration/StreamingCachingRetryE2ESpec.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Test.Langchain.Integration.StreamingCachingRetryE2ESpec +Description : Caching and retry resilience integration tests (Gemini or Ollama) +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +-} +module Test.Langchain.Integration.StreamingCachingRetryE2ESpec (tests) where + +import Control.Monad.Except (runExceptT) +import qualified Data.Text as T +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Cache.Core +import Langchain.Core.Model +import Langchain.Resilience.Retry +import Test.Langchain.TestHelpers (withAnyModel) + +assertCachingRetry :: CacheableChatModel m => m -> IO () +assertCachingRetry baseModel = do + cache <- newInMemoryCache + let cachedModel = withCaching baseModel cache + msgs = [userMessage "Respond with the single word 'OK'."] + + -- First call: populates cache + r1 <- runExceptT $ withRetry defaultRetryPolicy (invoke cachedModel msgs Nothing) + case r1 of + Left err -> assertFailure ("First invocation failed: " ++ show err) + Right msg1 -> do + assertBool "Response is non-empty" (not $ T.null (extractMessageText msg1)) + + -- Second call: hits cache (must return identical result) + r2 <- runExceptT $ withRetry defaultRetryPolicy (invoke cachedModel msgs Nothing) + case r2 of + Left err -> assertFailure ("Cached invocation failed: " ++ show err) + Right msg2 -> + extractMessageText msg2 @?= extractMessageText msg1 + +tests :: TestTree +tests = + testGroup + "Langchain.Integration.StreamingCachingRetryE2ESpec" + [ testCase "Model wrapped in Caching and Retry policies (OpenRouter or Ollama)" $ + withAnyModel assertCachingRetry assertCachingRetry + ] diff --git a/test/Test/Langchain/LLM/Core.hs b/test/Test/Langchain/LLM/Core.hs deleted file mode 100644 --- a/test/Test/Langchain/LLM/Core.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - -module Test.Langchain.LLM.Core (tests) where - -import Test.Tasty -import Test.Tasty.HUnit - -import Data.Aeson (Result (..), decode, fromJSON, toJSON) -import Data.Either -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import Langchain.Error (llmError) -import Langchain.LLM.Core - -data TestLLM = TestLLM - { responseText :: Text - , shouldSucceed :: Bool - } - -instance LLM TestLLM where - type LLMParams TestLLM = Text - type LLMStreamTokenType TestLLM = Text - - generate m _ mbParams = - pure $ - if shouldSucceed m - then Right (fromMaybe (responseText m) mbParams) - else Left (llmError "Test error" Nothing Nothing) - - chat m _ _ = - pure $ - if shouldSucceed m - then Right $ Message User (responseText m) defaultMessageData - else Left (llmError "Test error" Nothing Nothing) - - stream m _ handler _ = do - if shouldSucceed m - then do - onToken handler (responseText m) - onComplete handler - pure (Right ()) - else pure (Left (llmError "Test error" Nothing Nothing)) - -tests :: TestTree -tests = - testGroup - "LLMCoreTest" - [ testGroup - "Role" - [ testCase "has correct equality" $ do - assertEqual "System equals System" System System - assertEqual "User equals User" User User - assertEqual "Assistant equals Assistant" Assistant Assistant - assertEqual "Tool equals Tool" Tool Tool - assertBool "System should not equal User" (System /= User) - , testCase "can be converted to and from JSON" $ do - case fromJSON (toJSON System) of - Success r -> assertEqual "JSON roundtrip for System" System r - _ -> assertFailure "JSON conversion failed for System" - case fromJSON (toJSON User) of - Success r -> assertEqual "JSON roundtrip for User" User r - _ -> assertFailure "JSON conversion failed for User" - case fromJSON (toJSON Assistant) of - Success r -> assertEqual "JSON roundtrip for Assistant" Assistant r - _ -> assertFailure "JSON conversion failed for Assistant" - case fromJSON (toJSON Tool) of - Success r -> assertEqual "JSON roundtrip for Tool" Tool r - _ -> assertFailure "JSON conversion failed for Tool" - ] - , testGroup - "Message" - [ testCase "creates messages with correct fields" $ do - let msg = Message User "Hello" defaultMessageData - assertEqual "role should be User" User (role msg) - assertEqual "content should be 'Hello'" "Hello" (content msg) - assertEqual "messageData should be default" defaultMessageData (messageData msg) - , testCase "creates messages with custom message data" $ do - let customData = defaultMessageData {name = Just "Alice"} - let msg = Message User "Hello" customData - assertEqual "role should be User" User (role msg) - assertEqual "content should be 'Hello'" "Hello" (content msg) - assertEqual "name should be Just 'Alice'" (Just "Alice") (name (messageData msg)) - assertEqual "toolCalls should be Nothing" Nothing (toolCalls (messageData msg)) - ] - , testGroup - "MessageData" - [ testCase "creates default message data with all Nothing fields" $ do - let md = defaultMessageData - assertEqual "name should be Nothing" Nothing (name md) - assertEqual "toolCalls should be Nothing" Nothing (toolCalls md) - , {- - , testCase "serializes to correct JSON structure" $ do - let md = MessageData (Just "Alice") (Just ["tool1", "tool2"]) - expected = "{\"name\":\"Alice\",\"tool_calls\":[\"tool1\",\"tool2\"]}" - - assertEqual "JSON encoding of MessageData" expected (encode md) - - , testCase "deserializes from JSON correctly" $ do - let json = "{\"name\":\"Bob\",\"tool_calls\":[\"tool3\"]}" - expected = MessageData (Just "Bob") (Just ["tool3"]) - assertEqual "JSON decoding of MessageData" (Just expected) (decode json) - -} - testCase "handles partial JSON correctly" $ do - let json = "{\"name\":\"Charlie\"}" - expected = MessageData (Just "Charlie") Nothing Nothing Nothing - assertEqual "Partial JSON decoding of MessageData" (Just expected) (decode json) - ] - , testGroup - "LLM Typeclass" - [ testGroup - "generate" - [ testCase "generate uses provided LLMParams" $ do - let testLLM = TestLLM {responseText = "Default", shouldSucceed = True} - result <- generate testLLM "Prompt" (Just "CustomParam") - assertEqual "Should return CustomParam" (Right "CustomParam") result - , testCase "returns Right with response for successful generation" $ do - let successLLM = TestLLM "Success response" True - result <- generate successLLM "Test prompt" Nothing - assertEqual "Successful generation" (Right "Success response") result - , testCase "returns Left with error for failed generation" $ do - let failureLLM = TestLLM "Failure response" False - result <- generate failureLLM "Test prompt" Nothing - assertEqual "Failed generation" (Left (llmError "Test error" Nothing Nothing)) result - ] - , testGroup - "chat" - [ testCase "returns Right with response for successful chat" $ do - let successLLM = TestLLM "Success response" True - singleMsg = Message User "Test prompt" defaultMessageData - chatMsgs = singleMsg :| [] - result <- chat successLLM chatMsgs Nothing - assertBool "Successful chat" (isRight result) - , testCase "returns Left with error for failed chat" $ do - let failureLLM = TestLLM "Failure response" False - singleMsg = Message User "Test prompt" defaultMessageData - chatMsgs = singleMsg :| [] - result <- chat failureLLM chatMsgs Nothing - assertEqual "Failed chat" (Left (llmError "Test error" Nothing Nothing)) result - ] - , testGroup - "stream" - [ testCase "calls handlers and returns Right for successful stream" $ do - let successLLM = TestLLM "Success response" True - singleMsg = Message User "Test prompt" defaultMessageData - chatMsgs = singleMsg :| [] - handler = - StreamHandler - { onToken = \_ -> pure () - , onComplete = pure () - } - result <- stream successLLM chatMsgs handler Nothing - assertEqual "Successful stream" (Right ()) result - , testCase "returns Left with error for failed stream" $ do - let failureLLM = TestLLM "Failure response" False - singleMsg = Message User "Test prompt" defaultMessageData - chatMsgs = singleMsg :| [] - handler = - StreamHandler - { onToken = \_ -> pure () - , onComplete = pure () - } - result <- stream failureLLM chatMsgs handler Nothing - assertEqual "Failed stream" (Left (llmError "Test error" Nothing Nothing)) result - ] - ] - , testGroup - "ChatMessage" - [ testCase "creates non-empty list of messages" $ do - let msg1 = Message User "Hello" defaultMessageData - msg2 = Message Assistant "Hi there" defaultMessageData - chat_ = msg1 :| [msg2] - assertEqual "ChatMessage length" 2 (length chat_) - ] - ] diff --git a/test/Test/Langchain/LLM/Ollama.hs b/test/Test/Langchain/LLM/Ollama.hs deleted file mode 100644 --- a/test/Test/Langchain/LLM/Ollama.hs +++ /dev/null @@ -1,202 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Test.Langchain.LLM.Ollama (tests) where - -import Test.Tasty -import Test.Tasty.HUnit - -import Data.IORef -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T - -import Data.Aeson -import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Data.Ollama.Chat as O -import Langchain.Callback (Callback, Event (..)) -import Langchain.LLM.Core -import Langchain.LLM.Ollama -import qualified Langchain.Runnable.Core as Run - -captureEvents :: IO (Callback, IO [Event]) -captureEvents = do - eventsRef <- newIORef [] - let callback event = modifyIORef eventsRef (event :) - let getEvents = reverse <$> readIORef eventsRef - return (callback, getEvents) - -testModelName :: Text -testModelName = "qwen3:0.6b" - -tests :: TestTree -tests = - testGroup - "Ollama" - [ testCase "Show instance formats Ollama correctly" $ do - let ollama = Ollama "llama3" [] - show ollama @?= "Ollama \"llama3\"" - , testCase "generate returns text response for a prompt" $ do - (callback, getEvents) <- captureEvents - let ollama = Ollama testModelName [callback] - let prompt = "What is functional programming?" - result <- generate ollama prompt Nothing - case result of - Left err -> assertFailure $ "Expected success, got error: " ++ show err - Right response -> do - assertBool "Non-empty response expected" (T.length response > 0) - events <- getEvents - assertBool - "should contain all events" - (events `shouldContainAll` [LLMStart, LLMEnd]) - , testCase "generate returns error for invalid model" $ do - (callback, getEvents) <- captureEvents - let ollama = Ollama "non_existent_model" [callback] - let prompt = "Hello" - result <- generate ollama prompt Nothing - case result of - Left err -> do - assertBool - "Error should mention model" - ("model" `T.isInfixOf` T.pack (show err)) - events <- getEvents - assertBool - "LLM should tried to be started" - (events `shouldContainAll` [LLMStart]) - length (filter isErrorEvent events) @?= 1 - Right _ -> assertFailure "Expected error, but got success" - , testCase "chat returns text response for messages" $ do - (callback, getEvents) <- captureEvents - let ollama = Ollama testModelName [callback] - let messages = - Message - User - "What's the capital of France?" - defaultMessageData - :| [] - result <- chat ollama messages Nothing - case result of - Left err -> assertFailure $ "Expected success, got error: " ++ show err - Right response -> do - assertBool - "Response should mention Paris" - ("paris" `T.isInfixOf` T.toLower (content response)) - events <- getEvents - assertBool - "LLM should be completed" - (events `shouldContainAll` [LLMStart, LLMEnd]) - , testCase "chat handles multi-turn conversations" $ do - (callback, _) <- captureEvents - let ollama = Ollama testModelName [callback] - let messages = - Message System "You are a helpful assistant." defaultMessageData - :| [ Message - User - "What's the capital of France?" - defaultMessageData - , Message - Assistant - "The capital of France is Paris." - defaultMessageData - , Message - User - "And what about Italy?" - defaultMessageData - ] - result <- chat ollama messages Nothing - case result of - Left err -> assertFailure $ "Expected success, got error: " ++ show err - Right response -> - assertBool - "Response should mention Rome" - ("rome" `T.isInfixOf` T.toLower (content response)) - , testCase "stream calls handlers for streaming responses" $ do - let ollama = Ollama testModelName [] - let messages = Message User "Count from 1 to 5 briefly." defaultMessageData :| [] - - tokensRef <- newIORef [] - - let handler = - StreamHandler - { onToken = \token -> modifyIORef tokensRef (token :) - , onComplete = pure () - } - -- \| onComplete does not support Ollama - - result <- stream ollama messages handler Nothing - case result of - Left err -> assertFailure $ "Expected success, got error: " ++ show err - Right () -> do - tokens <- readIORef tokensRef - assertBool "Should receive tokens" (not (null tokens)) - , testCase "invoke calls chat with the input messages" $ do - let ollama = Ollama testModelName [] - let input = Message User "What is 2+2?" defaultMessageData :| [] - result <- Run.invoke ollama (input, Nothing) - case result of - Left err -> assertFailure $ "Expected success, got error: " ++ show err - Right response -> - assertBool - "Should mention 4" - ("4" `T.isInfixOf` T.toLower (content response)) - , {- qwen3:06b does not support insert - , testCase "generate appends suffix when provided" $ do - (callback, getEvents) <- captureEvents - let ollama = Ollama testModelName [callback] - let prompt = "What is functional programming?" - result <- generate ollama prompt Nothing - case result of - Left err -> assertFailure $ "Expected success, got error: " ++ err - Right response -> do - assertBool "Response should end with suffix" (T.isSuffixOf " [End]" response) - events <- getEvents - assertBool "should contain all events" - (events `shouldContainAll` [LLMStart, LLMEnd]) - -} - - testCase "generate uses system message for context" $ do - (callback, getEvents) <- captureEvents - let ollama = Ollama testModelName [callback] - let prompt = "What is 2 + 2?" - result <- generate ollama prompt Nothing - case result of - Left err -> assertFailure $ "Expected success, got error: " ++ show err - Right response -> do - assertBool "Response should mention 4" ("4" `T.isInfixOf` T.toLower response) - events <- getEvents - assertBool "should contain all events" (events `shouldContainAll` [LLMStart, LLMEnd]) - , testCase "generate returns JSON response when format is set" $ do - (callback, getEvents) <- captureEvents - let ollama = Ollama testModelName [callback] - let prompt = "What is JSON?" - let params = O.defaultChatOps {O.format = Just O.JsonFormat} - result <- generate ollama prompt (Just params) - case result of - Left err -> assertFailure $ "Expected success, got error: " ++ show err - Right response -> do - case eitherDecode (BSL.fromStrict $ T.encodeUtf8 response) :: Either String Value of - Left _ -> assertFailure "Response is not valid JSON" - Right _ -> return () - events <- getEvents - assertBool "should contain all events" (events `shouldContainAll` [LLMStart, LLMEnd]) - , testCase "chat returns JSON response when format is set" $ do - (callback, getEvents) <- captureEvents - let ollama = Ollama testModelName [callback] - let messages = Message User "What is JSON?" defaultMessageData :| [] - let params = O.defaultChatOps {O.format = Just O.JsonFormat} - result <- chat ollama messages (Just params) - case result of - Left err -> assertFailure $ "Expected success, got error: " ++ show err - Right response -> do - case eitherDecode (BSL.fromStrict $ T.encodeUtf8 (content response)) :: Either String Value of - Left _ -> assertFailure "Response is not valid JSON" - Right _ -> return () - events <- getEvents - assertBool "should contain all events" (events `shouldContainAll` [LLMStart, LLMEnd]) - ] - where - isErrorEvent (LLMError _) = True - isErrorEvent _ = False - - shouldContainAll xs = all (`elem` xs) diff --git a/test/Test/Langchain/MCP/McpSpec.hs b/test/Test/Langchain/MCP/McpSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/MCP/McpSpec.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.MCP.McpSpec (tests) where + +import qualified Data.Aeson as Aeson +import qualified Data.Text as T +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.MCP.Client +import Langchain.Tool.Core (Tool (..)) + +tests :: TestTree +tests = + testGroup + "Langchain.MCP.McpSpec" + [ testCase "newStdioMcpClient initializes transport and server name" $ do + let client = newStdioMcpClient "test-mcp" "npx" ["-y", "@modelcontextprotocol/server-everything"] + serverName client @?= "test-mcp" + clientTransport client @?= StdioTransport "npx" ["-y", "@modelcontextprotocol/server-everything"] + , testCase "mcpToolToLangchainTool converts remote tool to callable local Tool" $ do + let client = newStdioMcpClient "test-server" "echo" [] + toolInfo = + McpToolInfo + { mcpToolName = "echo_tool" + , mcpToolDescription = "Echoes inputs" + , mcpToolInputSchema = Aeson.object [] + } + langchainTool = mcpToolToLangchainTool client toolInfo + toolName langchainTool @?= "echo_tool" + toolDescription langchainTool @?= "Echoes inputs" + res <- toolExecute langchainTool (Aeson.object []) + case res of + Left err -> assertFailure ("Tool execution failed: " ++ show err) + Right out -> assertBool "Executed stdio tool" ("Executed MCP tool" `T.isInfixOf` out) + ] diff --git a/test/Test/Langchain/Memory/Core.hs b/test/Test/Langchain/Memory/Core.hs --- a/test/Test/Langchain/Memory/Core.hs +++ b/test/Test/Langchain/Memory/Core.hs @@ -2,192 +2,115 @@ module Test.Langchain.Memory.Core (tests) where +import Control.Concurrent.Async (forConcurrently_) +import Control.Monad.Except (runExceptT) +import qualified Data.Text as T import Test.Tasty import Test.Tasty.HUnit -import Langchain.LLM.Core (Message (..), Role (..), defaultMessageData) +import Langchain.Core.Model + ( assistantMessage + , systemMessage + , userMessage + ) import Langchain.Memory.Core -import Langchain.Runnable.Core -import qualified Data.List.NonEmpty as NE -import Data.Text (Text) -import Langchain.Error (toString) - -systemMsg :: Text -> Message -systemMsg text = Message System text defaultMessageData - -userMsg :: Text -> Message -userMsg text = Message User text defaultMessageData - -aiMsg :: Text -> Message -aiMsg text = Message Assistant text defaultMessageData +tests :: TestTree +tests = + testGroup + "Langchain.Memory.Core Tests" + [ utilityTests + , windowBufferMemoryTests + , concurrencyTests + ] utilityTests :: TestTree utilityTests = testGroup "Utility Functions Tests" - [ testCase "initialChatMessage should create chat with system message" $ do - let prompt = "You are a helpful assistant" - result = initialChatMessage prompt - NE.length result @?= 1 - NE.head result @?= systemMsg prompt - , testCase "trimChatMessage should keep specified number of messages" $ do + [ testCase "initialMessages creates list with a single system message" $ do + let result = initialMessages "You are a helpful assistant" + length result @?= 1 + case result of + (m : _) -> m @?= systemMessage "You are a helpful assistant" + [] -> assertFailure "Expected non-empty list" + , testCase "trimMessages keeps last n messages (non-system)" $ do let msgs = - NE.fromList - [ systemMsg "System" - , userMsg "User1" - , aiMsg "AI1" - , userMsg "User2" - ] - trimmed = trimChatMessage 2 msgs - NE.length trimmed @?= 2 - NE.toList trimmed @?= [aiMsg "AI1", userMsg "User2"] - , testCase "trimChatMessage should keep all messages if n >= length" $ do - let msgs = NE.fromList [systemMsg "System", userMsg "User1"] - trimmed = trimChatMessage 3 msgs - NE.length trimmed @?= 2 - NE.toList trimmed @?= [systemMsg "System", userMsg "User1"] - , testCase "trimChatMessage should handle minimum size of 1" $ do - let msgs = NE.fromList [systemMsg "System", userMsg "User1", aiMsg "AI1"] - trimmed = trimChatMessage 1 msgs - NE.length trimmed @?= 1 - NE.toList trimmed @?= [aiMsg "AI1"] - , testCase "addAndTrim should add message and trim history" $ do - let msgs = NE.fromList [systemMsg "System", userMsg "User1", aiMsg "AI1"] - newMsg = userMsg "User2" - result = addAndTrim 2 newMsg msgs - NE.length result @?= 2 - NE.toList result @?= [aiMsg "AI1", userMsg "User2"] + [ systemMessage "System" + , userMessage "User1" + , assistantMessage "AI1" + , userMessage "User2" + ] + trimmed = trimMessages 2 msgs + trimmed @?= [assistantMessage "AI1", userMessage "User2"] ] windowBufferMemoryTests :: TestTree windowBufferMemoryTests = testGroup "WindowBufferMemory Tests" - [ testCase "messages should return current messages" $ do - let initialMsgs = NE.fromList [systemMsg "System"] - memory = WindowBufferMemory 3 initialMsgs - result <- messages memory - case result of - Left err -> assertFailure $ "Expected Right but got Left: " ++ toString err + [ testCase "messages returns current messages" $ do + let initialMsgs = [systemMessage "System"] + memory <- newWindowBufferMemory 3 initialMsgs + res <- runExceptT $ messages memory + case res of + Left err -> assertFailure $ "Expected Right but got Left: " ++ show err Right msgs -> msgs @?= initialMsgs - , testCase "addMessage should add message when under capacity" $ do - let initialMsgs = NE.fromList [systemMsg "System"] - memory = WindowBufferMemory 3 initialMsgs - newMsg = userMsg "User1" - result <- addMessage memory newMsg - case result of - Left err -> assertFailure $ "Expected Right but got Left: " ++ toString err - Right newMemory -> do - msgsResult <- messages newMemory - case msgsResult of - Left err -> - assertFailure $ - "Expected Right but got Left: " ++ toString err - Right msgs -> - NE.toList msgs - @?= [ systemMsg "System" - , userMsg "User1" - ] - , testCase "addMessage should maintain max window size" $ do + , testCase "addMessage adds message when under capacity" $ do + let initialMsgs = [systemMessage "System"] + memory <- newWindowBufferMemory 3 initialMsgs + res <- runExceptT $ do + addMessage memory (userMessage "User1") + messages memory + case res of + Left err -> assertFailure $ "Expected Right but got Left: " ++ show err + Right msgs -> msgs @?= [systemMessage "System", userMessage "User1"] + , testCase "addMessage trims oldest non-system message when at capacity" $ do let initialMsgs = - NE.fromList - [ systemMsg "System" - , userMsg "User1" - , aiMsg "AI1" - ] - memory = WindowBufferMemory 3 initialMsgs - newMsg = userMsg "User2" - result <- addMessage memory newMsg - case result of - Left err -> assertFailure $ "Expected Right but got Left: " ++ toString err - Right newMemory -> do - msgsResult <- messages newMemory - case msgsResult of - Left err -> assertFailure $ "Expected Right but got Left: " ++ toString err - Right msgs -> do - NE.length msgs @?= 3 - NE.toList msgs - @?= [ systemMsg "System" - , aiMsg "AI1" - , userMsg "User2" - ] - , testCase "addUserMessage should add message with User role" $ do - let initialMsgs = NE.fromList [systemMsg "System"] - memory = WindowBufferMemory 3 initialMsgs - result <- addUserMessage memory "Hello" - case result of - Left err -> assertFailure $ "Expected Right but got Left: " ++ toString err - Right newMemory -> do - msgsResult <- messages newMemory - case msgsResult of - Left err -> assertFailure $ "Expected Right but got Left: " ++ toString err - Right msgs -> do - NE.length msgs @?= 2 - NE.toList msgs @?= [systemMsg "System", userMsg "Hello"] - , testCase "addAiMessage should add message with Assistant role" $ do - let initialMsgs = NE.fromList [systemMsg "System"] - memory = WindowBufferMemory 3 initialMsgs - result <- addAiMessage memory "I can help" - case result of - Left err -> assertFailure $ "Expected Right but got Left: " ++ toString err - Right newMemory -> do - msgsResult <- messages newMemory - case msgsResult of - Left err -> assertFailure $ "Expected Right but got Left: " ++ toString err - Right msgs -> do - NE.length msgs @?= 2 - NE.toList msgs - @?= [ systemMsg "System" - , aiMsg "I can help" - ] - , testCase "clear should reset to just system message" $ do + [ systemMessage "System" + , userMessage "User1" + , assistantMessage "AI1" + ] + memory <- newWindowBufferMemory 3 initialMsgs + res <- runExceptT $ do + addMessage memory (userMessage "User2") + messages memory + case res of + Left err -> assertFailure $ "Expected Right but got Left: " ++ show err + Right msgs -> + msgs @?= [systemMessage "System", assistantMessage "AI1", userMessage "User2"] + , testCase "clear resets to default system message" $ do let initialMsgs = - NE.fromList - [ systemMsg "System" - , userMsg "User1" - , aiMsg "AI1" - ] - memory = WindowBufferMemory 3 initialMsgs - result <- clear memory - case result of - Left err -> assertFailure $ "Expected Right but got Left: " ++ toString err - Right newMemory -> do - msgsResult <- messages newMemory - case msgsResult of - Left err -> - assertFailure $ - "Expected Right but got Left: " - ++ toString err - Right msgs -> do - NE.length msgs @?= 1 - NE.head msgs @?= systemMsg "You are an AI model" + [ systemMessage "System" + , userMessage "User1" + , assistantMessage "AI1" + ] + memory <- newWindowBufferMemory 3 initialMsgs + res <- runExceptT $ do + clear memory + messages memory + case res of + Left err -> assertFailure $ "Expected Right but got Left: " ++ show err + Right msgs -> do + length msgs @?= 1 + case msgs of + (m : _) -> m @?= systemMessage "You are a helpful AI assistant" + [] -> assertFailure "Expected non-empty messages" ] -runnableTests :: TestTree -runnableTests = +concurrencyTests :: TestTree +concurrencyTests = testGroup - "Runnable Instance Tests" - [ testCase "invoke should add user message" $ do - let initialMsgs = NE.fromList [systemMsg "System"] - memory = WindowBufferMemory 3 initialMsgs - result <- invoke memory "Test input" + "Concurrency Tests" + [ testCase "100 concurrent writes produce consistent window size" $ do + let initialMsgs = [systemMessage "System"] + maxSize = 200 + memory <- newWindowBufferMemory maxSize initialMsgs + forConcurrently_ [1 .. 100 :: Int] $ \i -> do + _ <- runExceptT $ addMessage memory (userMessage $ "Msg " <> T.pack (show i)) + pure () + result <- runExceptT $ messages memory case result of - Left err -> assertFailure $ "Expected Right but got Left: " ++ toString err - Right newMemory -> do - msgsResult <- messages newMemory - case msgsResult of - Left err -> assertFailure $ "Expected Right but got Left: " ++ toString err - Right msgs -> do - NE.length msgs @?= 2 - NE.toList msgs @?= [systemMsg "System", userMsg "Test input"] - ] - -tests :: TestTree -tests = - testGroup - "Langchain.Memory.Core Tests" - [ utilityTests - , windowBufferMemoryTests - , runnableTests + Left err -> assertFailure $ "Expected Right but got Left: " ++ show err + Right msgs -> length msgs @?= 101 ] diff --git a/test/Test/Langchain/Memory/EntitySpec.hs b/test/Test/Langchain/Memory/EntitySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Memory/EntitySpec.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Memory.EntitySpec (tests) where + +import Control.Monad.Except (runExceptT) +import qualified Data.Map.Strict as Map +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Core.Model (userMessage) +import Langchain.Memory.Core (BaseMemory (..)) +import Langchain.Memory.Entity +import Test.Langchain.Provider.Mock (newMockModel) + +tests :: TestTree +tests = + testGroup + "Langchain.Memory.EntitySpec" + [ testCase "EntityMemory extracts and injects entities into conversation" $ do + let mockModel = newMockModel "User: Likes Haskell and functional programming\nProject: Langchain-HS" + mem <- newEntityMemory mockModel [] + res <- runExceptT $ do + addMessage mem (userMessage "I am working on Langchain-HS and love functional programming") + entities <- getEntities mem + allMsgs <- messages mem + pure (entities, allMsgs) + case res of + Left err -> assertFailure ("EntityMemory failed: " ++ show err) + Right (entities, msgs) -> do + Map.lookup "User" entities @?= Just "Likes Haskell and functional programming" + Map.lookup "Project" entities @?= Just "Langchain-HS" + assertBool "Includes system message with entities" (length msgs >= 2) + ] diff --git a/test/Test/Langchain/Memory/SummarySpec.hs b/test/Test/Langchain/Memory/SummarySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Memory/SummarySpec.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Memory.SummarySpec (tests) where + +import Control.Monad.Except (runExceptT) +import qualified Data.Text as T +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Core.Model (extractMessageText, userMessage) +import Langchain.Memory.Core (BaseMemory (..)) +import Langchain.Memory.Summary +import Test.Langchain.Provider.Mock (newMockModel) + +tests :: TestTree +tests = + testGroup + "Langchain.Memory.SummarySpec" + [ testCase "SummaryMemory summarizes when exceeding threshold" $ do + let mockModel = newMockModel "Summarized context of user questions" + mem <- newSummaryMemory mockModel 3 [] + res <- runExceptT $ do + addMessage mem (userMessage "Message 1") + addMessage mem (userMessage "Message 2") + addMessage mem (userMessage "Message 3") + addMessage mem (userMessage "Message 4") + summaryTxt <- getSummary mem + allMsgs <- messages mem + pure (summaryTxt, allMsgs) + case res of + Left err -> assertFailure ("SummaryMemory failed: " ++ show err) + Right (sTxt, msgs) -> do + sTxt @?= "Summarized context of user questions" + assertBool + "Messages contains summary in system message" + (any (\m -> "Summary" `T.isInfixOf` extractMessageText m) msgs) + ] diff --git a/test/Test/Langchain/Memory/TokenBufferMemory.hs b/test/Test/Langchain/Memory/TokenBufferMemory.hs --- a/test/Test/Langchain/Memory/TokenBufferMemory.hs +++ b/test/Test/Langchain/Memory/TokenBufferMemory.hs @@ -1,129 +1,66 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Test.Langchain.Memory.TokenBufferMemory (tests) where -import Data.Either (isRight) -import qualified Data.List.NonEmpty as NE -import Data.Text (Text) +import Control.Monad.Except (runExceptT) import qualified Data.Text as T -import Langchain.Error (llmError) -import Langchain.LLM.Core -import Langchain.Memory.Core (BaseMemory (..)) -import qualified Langchain.Memory.TokenBufferMemory as TB import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit -#if MIN_VERSION_base(4,19,0) -import Data.List (unsnoc) -#else -unsnoc :: [a] -> Maybe ([a], a) -unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing -#endif - -mkMsg :: Role -> Text -> Message -mkMsg role1 content1 = Message role1 content1 defaultMessageData - -runAddAndGet :: TB.TokenBufferMemory -> [Message] -> IO ChatHistory -runAddAndGet initial msgs = do - TB.tokenBufferMessages - <$> foldl - ( \mem_ msg -> do - mem <- mem_ - eRes <- addMessage mem msg - case eRes of - Left _ -> pure mem - Right r -> pure r - ) - (pure initial) - msgs +import Langchain.Core.Error (errorMessage) +import Langchain.Core.Model + ( systemMessage + , userMessage + ) +import Langchain.Memory.Core (BaseMemory (..)) +import qualified Langchain.Memory.Core as TB --- Tests tests :: TestTree tests = testGroup "TokenBufferMemory Tests" - [ countTokensTests - , addMessageTests - , addUserAndAiMessageTests - , clearTest - ] - -countTokensTests :: TestTree -countTokensTests = - testGroup - "countTokens" - [ testCase "Empty message list" $ - TB.countTokens [] @?= 0 - , testCase "Single message" $ - TB.countTokens [mkMsg System "abc"] @?= ceiling (3 / 4 :: Double) - , testCase "Multiple messages" $ - TB.countTokens [mkMsg User "hello", mkMsg Assistant "world"] @?= ceiling (5 / 4 :: Double) * 2 - ] - -addMessageTests :: TestTree -addMessageTests = - testGroup - "addMessage" - [ testCase "Add within limit" $ do - let initial = TB.TokenBufferMemory 100 (NE.fromList [mkMsg System ""]) - newMsg = mkMsg User "content" - updated <- runAddAndGet initial [newMsg] - NE.length updated @?= 2 - , testCase "Exceeding token limit trims old messages" $ do - -- Total tokens allowed: 6 - -- Each message has 3 characters ⇒ ~1 token each - let maxTok = 2 - baseMsg = mkMsg System "aaa" - userMsg = mkMsg User "bbb" - aiMsg = mkMsg Assistant "ccc" - - initial = TB.TokenBufferMemory maxTok (NE.fromList [baseMsg]) - - updated <- runAddAndGet initial [userMsg, aiMsg] - NE.toList updated @?= [baseMsg, aiMsg] -- first message gets trimmed - , testCase "New message alone exceeds limit" $ do - let initial = TB.TokenBufferMemory 1 (NE.fromList [mkMsg System ""]) - bigMsg = mkMsg User (T.replicate 10 "a") -- 10 chars → 2.5 tokens (ceil to 3) - result <- addMessage initial bigMsg - assertEqual - "New message is exceeding limit" - (Left (llmError "New message is exceeding limit" Nothing Nothing)) - result - ] - -addUserAndAiMessageTests :: TestTree -addUserAndAiMessageTests = - testGroup - "addUserMessage and addAiMessage" - [ testCase "addUserMessage adds User role message" $ do - let initial = TB.TokenBufferMemory 100 (NE.fromList [mkMsg System ""]) - userContent = "Hello!" - updated <- addUserMessage initial userContent - case updated of - Right mem -> do - let msgs = NE.toList $ TB.tokenBufferMessages mem - unsnoc msgs @?= Just ([mkMsg System ""], mkMsg User userContent) - Left err -> assertFailure $ "Unexpected Left: " ++ show err - , testCase "addAiMessage adds Assistant role message" $ do - let initial = TB.TokenBufferMemory 100 (NE.fromList [mkMsg System ""]) - aiContent = "I'm an assistant." - updated <- addAiMessage initial aiContent - case updated of - Right mem -> do - let msgs = NE.toList $ TB.tokenBufferMessages mem - unsnoc msgs @?= Just ([mkMsg System ""], mkMsg Assistant aiContent) - Left err -> assertFailure $ "Unexpected Left: " ++ show err + [ testCase "Initializes with provided messages" $ do + mem <- TB.newTokenBufferMemory 100 [systemMessage "You are an AI model"] + TB.maxTokens mem @?= 100 + res <- runExceptT $ messages mem + res @?= Right [systemMessage "You are an AI model"] + , testCase "Adds message within token limit" $ do + let sysMsg = systemMessage "sys" + user1 = userMessage "12345678" + user2 = userMessage "12345678" + mem <- TB.newTokenBufferMemory 10 [sysMsg, user1] + res <- runExceptT $ do + addMessage mem user2 + messages mem + case res of + Left err -> assertFailure $ "Expected Right but got Left: " ++ show err + Right msgs -> msgs @?= [sysMsg, user1, user2] + , testCase "Evicts oldest non-system message when exceeding token limit" $ do + let sysMsg = systemMessage "sys!" + user1 = userMessage "12345678" + user2 = userMessage "12345678" + mem <- TB.newTokenBufferMemory 4 [sysMsg, user1] + res <- runExceptT $ do + addMessage mem user2 + messages mem + case res of + Left err -> assertFailure $ "Expected Right but got Left: " ++ show err + Right msgs -> msgs @?= [sysMsg, user2] + , testCase "Returns error when message itself exceeds token limit" $ do + let sysMsg = systemMessage "12345678" + userMsg = userMessage "12345678901234567890" + mem <- TB.newTokenBufferMemory 3 [sysMsg] + res <- runExceptT $ addMessage mem userMsg + case res of + Left err -> + assertBool "Error mentions exceeds" ("exceeds" `T.isInfixOf` errorMessage err) + Right _ -> assertFailure "Expected Left due to overflow" + , testCase "clear resets to default system message" $ do + mem <- TB.newTokenBufferMemory 100 [userMessage "old"] + res <- runExceptT $ do + clear mem + messages mem + case res of + Right msgs -> msgs @?= [systemMessage "You are a helpful AI assistant"] + Left _ -> assertFailure "Clear failed unexpectedly" ] - -clearTest :: TestTree -clearTest = - testCase "clear resets messages to default system message" $ do - let initial = TB.TokenBufferMemory 100 (NE.fromList [mkMsg User "old"]) - cleared <- clear initial - assertBool "Clear should be right" (isRight cleared) - case cleared of - Right mem -> - TB.tokenBufferMessages mem - @?= NE.singleton (mkMsg System "You are an AI model") - Left _ -> assertFailure "Clear failed unexpectedly" diff --git a/test/Test/Langchain/ObservabilitySpec.hs b/test/Test/Langchain/ObservabilitySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/ObservabilitySpec.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.ObservabilitySpec (tests) where + +import Control.Concurrent.STM (atomically, modifyTVar') +import Control.Monad.Except (runExceptT) +import qualified Data.Map.Strict as Map +import Data.Maybe (isJust) +import qualified Data.Text as T +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Observability + +tests :: TestTree +tests = + testGroup + "Langchain.Observability" + [ testGroup + "Structured Logging" + [ testCase "InMemoryLogger records events and respects minLevel" $ do + logger <- newInMemoryLogger InfoLevel + let logHandler = + Logger + { minLevel = InfoLevel + , writeLog = \ev -> do + atomically $ modifyTVar' (inMemoryVar logger) (\ls -> ls ++ [ev]) + } + logDebug logHandler "Agent" "This debug log should be ignored" + logInfo logHandler "Agent" "Starting agent turn" + logWarn logHandler "Retriever" "Slow response from vector store" + logError logHandler "Model" "Rate limit reached" + + logs <- getInMemoryLogs logger + case logs of + (firstLog : _) -> do + length logs @?= 3 + logLevel firstLog @?= InfoLevel + logMessage firstLog @?= "Starting agent turn" + [] -> assertFailure "Expected logs to be non-empty" + , testCase "logEvent attaches custom metadata" $ do + logger <- newInMemoryLogger DebugLevel + let logHandler = + Logger + { minLevel = DebugLevel + , writeLog = \ev -> do + atomically $ modifyTVar' (inMemoryVar logger) (\ls -> ls ++ [ev]) + } + let meta = Map.fromList [("model", "qwen2.5:7b"), ("tokens", "128")] + logEvent logHandler InfoLevel "Provider" "Model invocation complete" meta + + logs <- getInMemoryLogs logger + case logs of + [firstLog] -> logMetadata firstLog @?= meta + _ -> assertFailure ("Expected exactly 1 log, got " ++ show (length logs)) + ] + , testGroup + "OpenTelemetry Tracing" + [ testCase "withSpan wraps computation, records duration and Ok status" $ do + tracer <- newOTelTracer (Just "trace-100") + res <- runExceptT $ withSpan tracer "llm_invoke" Nothing ClientSpan (Map.singleton "provider" "ollama") $ do + pure ("success response" :: T.Text) + res @?= Right "success response" + + spans <- getSpans tracer + case spans of + [sp] -> do + spanName sp @?= "llm_invoke" + spanTraceId sp @?= "trace-100" + spanStatus sp @?= StatusOk + assertBool "Duration recorded" (isJust (spanDurationMicros sp)) + _ -> assertFailure ("Expected exactly 1 span, got " ++ show (length spans)) + , testCase "exportSpansJson exports valid JSON formatted trace" $ do + tracer <- newOTelTracer (Just "trace-export") + _ <- startSpan tracer "step1" Nothing InternalSpan Map.empty + jsonText <- exportSpansJson tracer + assertBool "Contains span name" ("step1" `T.isInfixOf` jsonText) + assertBool "Contains trace-export" ("trace-export" `T.isInfixOf` jsonText) + ] + ] diff --git a/test/Test/Langchain/OutputParser/AdvancedParsersSpec.hs b/test/Test/Langchain/OutputParser/AdvancedParsersSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/OutputParser/AdvancedParsersSpec.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Langchain.OutputParser.AdvancedParsersSpec (tests) where + +import Control.Monad.Except (runExceptT) +import Data.Aeson (FromJSON, ToJSON, Value (..)) +import qualified Data.Aeson.KeyMap as KM +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import qualified Data.Vector as V +import GHC.Generics (Generic) +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Core.Model (userMessage) +import Langchain.OutputParser.Structured +import Test.Langchain.Provider.Mock (newMockModel) + +data TestPerson = TestPerson + { personName :: Text + , personAge :: Int + } + deriving (Show, Eq, Generic, ToJSON, FromJSON, StructuredOutput) + +instance TypeSchema TestPerson + +data TestOptionalPerson = TestOptionalPerson + { optName :: Text + , optBio :: Maybe Text + , optRating :: Maybe Double + } + deriving (Show, Eq, Generic, ToJSON, FromJSON, StructuredOutput) + +data TestCompany = TestCompany + { companyName :: Text + , companyFounder :: TestPerson + , companyEmployees :: [TestPerson] + } + deriving (Show, Eq, Generic, ToJSON, FromJSON, StructuredOutput) + +tests :: TestTree +tests = + testGroup + "Langchain.OutputParser.AdvancedParsersSpec" + [ testCase "structuredInvoke extracts typed data structure from JSON output" $ do + let mockModel = newMockModel "```json\n{\"personName\":\"Grace Hopper\",\"personAge\":85}\n```" + res <- runExceptT $ structuredInvoke mockModel [userMessage "Who was Grace Hopper?"] + case res of + Left err -> assertFailure ("structuredInvoke failed: " ++ show err) + Right (person :: TestPerson) -> do + personName person @?= "Grace Hopper" + personAge person @?= 85 + , testCase "optional fields are omitted from required schema list" $ do + let s = outputSchema (Proxy :: Proxy TestOptionalPerson) + case s of + Object obj -> case KM.lookup "required" obj of + Just (Array arr) -> do + let reqs = [t | String t <- V.toList arr] + reqs @?= ["optName"] + _ -> assertFailure "Expected required array in schema" + _ -> assertFailure "Expected Object schema" + , testCase "nested records generate composite JSON schema objects" $ do + let s = outputSchema (Proxy :: Proxy TestCompany) + case s of + Object obj -> case KM.lookup "properties" obj of + Just (Object pObj) -> do + case KM.lookup "companyFounder" pObj of + Just (Object fObj) -> KM.lookup "type" fObj @?= Just (String "object") + _ -> assertFailure "Expected companyFounder to be object" + case KM.lookup "companyEmployees" pObj of + Just (Object eObj) -> KM.lookup "type" eObj @?= Just (String "array") + _ -> assertFailure "Expected companyEmployees to be array" + _ -> assertFailure "Expected properties in schema" + _ -> assertFailure "Expected Object schema" + , testCase "toOllamaSchema and fromOllamaSchema bridge round-trip" $ do + let s = outputSchema (Proxy :: Proxy TestCompany) + case toOllamaSchema s of + Nothing -> assertFailure "toOllamaSchema failed for TestCompany" + Just ollamaS -> do + let rt = fromOllamaSchema ollamaS + toOllamaSchema rt @?= Just ollamaS + ] diff --git a/test/Test/Langchain/OutputParser/Core.hs b/test/Test/Langchain/OutputParser/Core.hs --- a/test/Test/Langchain/OutputParser/Core.hs +++ b/test/Test/Langchain/OutputParser/Core.hs @@ -7,7 +7,7 @@ import Data.Aeson import Data.Text (Text) -import Langchain.Error (LangchainError) +import Langchain.Core.Error (LangchainError) import Langchain.OutputParser.Core data Person = Person diff --git a/test/Test/Langchain/PromptTemplate.hs b/test/Test/Langchain/PromptTemplate.hs deleted file mode 100644 --- a/test/Test/Langchain/PromptTemplate.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Langchain.PromptTemplate (tests) where - -import qualified Data.Map.Strict as HM -import qualified Data.Text as T -import Langchain.PromptTemplate -import Langchain.Runnable.Core (invoke) -import Test.Tasty -import Test.Tasty.HUnit - -tests :: TestTree -tests = - testGroup - "PromptTemplate Tests" - [ testGroup - "PromptTemplate" - [ testCase "correctly interpolates all variables" $ - renderPrompt template vars @?= Right "Hello, Alice! Welcome to Wonderland." - , testCase "handles templates with no variables" $ - let noVarTemplate = PromptTemplate "Hello, world!" - in renderPrompt noVarTemplate HM.empty @?= Right "Hello, world!" - , testCase "handles templates with repeated variables" $ - let repeatTemplate = PromptTemplate "{name} likes {food}. {name} eats {food} every day." - repeatVars = HM.fromList [("name", "Bob"), ("food", "pizza")] - in renderPrompt repeatTemplate repeatVars @?= Right "Bob likes pizza. Bob eats pizza every day." - , testCase "returns an error for missing variables" $ - let missingVars = HM.fromList [("name", "Charlie")] - in case renderPrompt template missingVars of - Left err -> "place" `T.isInfixOf` T.pack (show err) @? "Expected error to contain 'place'" - Right _ -> assertFailure "Expected an error for missing variable" - {- TODO: Need to take care of incomplete brace cases - , testCase "handles unclosed braces" $ - let invalidTemplate = PromptTemplate "Hello, {name! Welcome to {place}." - in case renderPrompt invalidTemplate vars of - Left err -> err @?= "Unclosed brace" - Right _ -> assertFailure "Expected an error for unclosed brace" - , testCase "handles complex nesting of placeholders" $ - let complexTemplate = PromptTemplate "{{name}} is not a placeholder but {name} is." - in renderPrompt complexTemplate vars @?= Right "{Alice} is not a placeholder but Alice is." - -} - ] - , testCase "Runnable instance for PromptTemplate - invoke with variables" $ do - let template1 = PromptTemplate "Hello, {name}!" - vars1 = HM.fromList [("name", "Dave")] - result <- invoke template1 vars1 - result @?= Right "Hello, Dave!" - , testGroup - "FewShotPromptTemplate" - [ testCase "correctly formats a few-shot prompt" $ - let expected = - "Examples of {type}:\nInput: Hello\nOutput: Bonjour\n\nInput: Goodbye\nOutput: Au revoir\nNow translate: {query}" - in renderFewShotPrompt fewShotTemplate @?= Right expected - , testCase "handles empty examples list" $ - let emptyExamples = fewShotTemplate {fsExamples = []} - in renderFewShotPrompt emptyExamples @?= Right "Examples of {type}:\n\nNow translate: {query}" - , testCase "handles empty prefix and suffix" $ - let noPreSuf = fewShotTemplate {fsPrefix = "", fsSuffix = ""} - in renderFewShotPrompt noPreSuf - @?= Right "Input: Hello\nOutput: Bonjour\n\nInput: Goodbye\nOutput: Au revoir" - , testCase "returns an error when example variables are missing" $ - let badExamples = - fewShotTemplate - { fsExamples = [HM.fromList [("wrong", "value")]] - , fsExampleTemplate = "{input} translates to {output}" - } - in case renderFewShotPrompt badExamples of - Left err -> - "input" `T.isInfixOf` T.pack (show err) - @? "Expected error to contain 'input'" - Right _ -> - assertFailure - "Expected an error for missing example variable" - , testCase "correctly uses the example separator" $ - let customSep = fewShotTemplate {fsExampleSeparator = " ### "} - in renderFewShotPrompt customSep - @?= Right - "Examples of {type}:\nInput: Hello\nOutput: Bonjour ### Input: Goodbye\nOutput: Au revoir\nNow translate: {query}" - ] - ] - where - template = PromptTemplate "Hello, {name}! Welcome to {place}." - vars = HM.fromList [("name", "Alice"), ("place", "Wonderland")] - fewShotTemplate = - FewShotPromptTemplate - { fsPrefix = "Examples of {type}:\n" - , fsExamples = - [ HM.fromList [("input", "Hello"), ("output", "Bonjour")] - , HM.fromList [("input", "Goodbye"), ("output", "Au revoir")] - ] - , fsExampleTemplate = "Input: {input}\nOutput: {output}" - , fsExampleSeparator = "\n\n" - , fsSuffix = "\nNow translate: {query}" - } diff --git a/test/Test/Langchain/PromptTemplate/Chat/ChatPromptTemplateSpec.hs b/test/Test/Langchain/PromptTemplate/Chat/ChatPromptTemplateSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/PromptTemplate/Chat/ChatPromptTemplateSpec.hs @@ -0,0 +1,661 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.PromptTemplate.Chat.ChatPromptTemplateSpec (tests) where + +import Data.Aeson (decode, encode, object, (.=)) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Core.Model.Types + ( ContentBlock (..) + , ImageContent (..) + , ImageSource (..) + , Message (..) + , Role (..) + , extractMessageText + , textMessage + , userMessage + ) +import Langchain.PromptTemplate.Chat.ChatPromptTemplate + ( ChatPromptInput (..) + , ChatPromptMessage + , ChatPromptTemplate (..) + , ContentPromptBlock (..) + , PartialValue (..) + , append + , contentMessage + , extend + , format + , formatPrompt + , fromMessages + , fromTemplate + , fromTemplateWithOptions + , invoke + , message + , messagesPlaceholder + , messagesPlaceholderWithOptions + , partial + , templateMessage + , toMessages + , toString + ) +import Langchain.PromptTemplate.Chat.MessagesPlaceholder + ( MessagesPlaceholder (..) + , MessagesPlaceholderOptions (..) + ) +import Langchain.PromptTemplate.Prompt (PromptTemplateOptions (..), TemplateFormat (..)) + +tests :: TestTree +tests = + testGroup + "ChatPromptTemplate" + [ fromTemplateTests + , fromMessagesTests + , richContentTests + , formatPromptTests + , missingVariableTests + , partialTests + , appendExtendTests + , invokeTests + , serializationTests + ] + +fromTemplateTests :: TestTree +fromTemplateTests = + testGroup + "fromTemplate" + [ testCase "creates a chat prompt template" $ do + let actual = fromTemplate "hi {foo} {bar}" + expected = + ChatPromptTemplate + { messages = + [templateMessage User "hi {foo} {bar}"] + , inputVariables = ["foo", "bar"] + } + actual @?= expected + , testCase "creates a chat prompt template with partials" $ do + let actual = + fromTemplateWithOptions + "hi {foo} {bar}" + (PromptTemplateOptions (Map.singleton "foo" "jim")) + inputVariables actual @?= ["bar"] + case formatPrompt actual (Map.singleton "bar" "bob") of + Left err -> assertFailure $ "Expected formatted prompt, got " <> show err + Right promptValue -> toMessages promptValue @?= [userMessage "hi jim bob"] + ] + +fromMessagesTests :: TestTree +fromMessagesTests = + testGroup + "fromMessages" + [ testCase "preserves static messages" $ do + let actual = + fromMessages $ + chatPromptMessages <> [message (userMessage "foo")] + case actual of + ChatPromptTemplate {inputVariables = actualInputVariables} -> + actualInputVariables @?= ["context", "foo", "bar"] + length (messages actual) @?= 5 + case formatPrompt actual withMessagesVariables of + Left err -> assertFailure $ "Expected formatted prompt, got " <> show err + Right promptValue -> + last (toMessages promptValue) @?= userMessage "foo" + ] + +formatPromptTests :: TestTree +formatPromptTests = + testGroup + "formatPrompt / format" + [ testCase "formats all chat prompt messages" $ do + let actual = formatPrompt chatPromptTemplate promptVariables + case actual of + Left err -> assertFailure $ "Expected formatted prompt, got " <> show err + Right promptValue -> do + let promptMessages = toMessages promptValue + length promptMessages @?= 4 + map extractMessageText promptMessages + @?= [ "Here's some context: context" + , "Hello foo, I'm bar. Thanks for the context" + , "I'm an AI. I'm foo. I'm bar." + , "I'm a generic message. I'm foo. I'm bar." + ] + toString promptValue @?= expectedFormattedPrompt + format chatPromptTemplate promptVariables @?= Right expectedFormattedPrompt + ] + +missingVariableTests :: TestTree +missingVariableTests = + testGroup + "missing variables" + [ testCase "fails for missing FString variables in chat messages" $ do + let template = fromMessages [templateMessage User "Hi {foo}"] + assertMissingVariable "Parameter not found: foo" (formatPrompt template Map.empty) + , testCase "fails for missing FString variables in multipart text blocks" $ do + let template = fromMessages [contentMessage User [TextPromptBlock FString "Hi {foo}"]] + assertMissingVariable "Parameter not found: foo" (formatPrompt template Map.empty) + , testCase "fails for missing FString variables in image url blocks" $ do + let template = + fromMessages + [ contentMessage + User + [ ImagePromptBlock FString $ + ImageContent (ImageUrl "https://example.com/{foo}") Nothing Nothing + ] + ] + assertMissingVariable "Parameter not found: foo" (formatPrompt template Map.empty) + , testCase "fails for missing FString variables in image detail blocks" $ do + let template = + fromMessages + [ contentMessage + User + [ ImagePromptBlock FString $ + ImageContent (ImageUrl "https://example.com/image.png") (Just "{foo}") Nothing + ] + ] + assertMissingVariable "Parameter not found: foo" (formatPrompt template Map.empty) + , testCase "fails for missing FString variables in image metadata blocks" $ do + let template = + fromMessages + [ contentMessage + User + [ ImagePromptBlock FString $ + ImageContent + (ImageUrl "https://example.com/image.png") + Nothing + (Just $ object ["cache_control" .= object ["type" .= ("{foo}" :: Text)]]) + ] + ] + assertMissingVariable "Parameter not found: foo" (formatPrompt template Map.empty) + ] + +richContentTests :: TestTree +richContentTests = + testGroup + "rich content" + [ testCase "formats multipart text blocks" $ do + let template = + fromMessages + [ templateMessage System "You are an AI assistant named {name}." + , contentMessage + User + [TextPromptBlock FString "What's in this image?", TextPromptBlock FString "Oh nvm"] + ] + + case formatPrompt template (Map.singleton "name" "R2D2") of + Left err -> assertFailure $ "Expected multipart text prompt, got " <> show err + Right promptValue -> + toMessages promptValue + @?= [ textMessage System "You are an AI assistant named R2D2." + , Message + User + (TextBlock "What's in this image?" :| [TextBlock "Oh nvm"]) + Nothing + Nothing + Nothing + Map.empty + ] + , testCase "formats templated multipart text blocks" $ do + let template = + fromMessages + [ templateMessage System "You are an AI assistant named {name}." + , contentMessage + User + [TextPromptBlock FString "What's in this {object_name}?", TextPromptBlock FString "Oh nvm"] + ] + variables = Map.fromList [("name", "R2D2"), ("object_name", "image")] + + case formatPrompt template variables of + Left err -> assertFailure $ "Expected templated multipart text prompt, got " <> show err + Right promptValue -> + toMessages promptValue + @?= [ textMessage System "You are an AI assistant named R2D2." + , Message + User + (TextBlock "What's in this image?" :| [TextBlock "Oh nvm"]) + Nothing + Nothing + Nothing + Map.empty + ] + , testCase "formats system template with partial variables" $ do + let graphCreatorContent = "\n Your instructions are:\n {instructions}\n History:\n {history}\n " + template = + partial + (fromMessages [templateMessage System graphCreatorContent]) + (Map.singleton "instructions" (PartialText "{}")) + + case formatPrompt template (Map.singleton "history" "history") of + Left err -> assertFailure $ "Expected system partial prompt, got " <> show err + Right promptValue -> + toMessages promptValue + @?= [ textMessage + System + "\n Your instructions are:\n {}\n History:\n history\n " + ] + , testCase "formats system multipart text template" $ do + let graphCreatorContent1 = "\n This is the prompt for the first test:\n {variables}\n " + graphCreatorContent2 = "\n This is the prompt for the second test:\n {variables}\n " + template = + fromMessages + [ contentMessage + System + [ TextPromptBlock FString graphCreatorContent1 + , TextPromptBlock FString graphCreatorContent2 + ] + ] + + case formatPrompt template (Map.singleton "variables" "foo") of + Left err -> assertFailure $ "Expected system multipart text prompt, got " <> show err + Right promptValue -> + toMessages promptValue + @?= [ Message + System + ( TextBlock "\n This is the prompt for the first test:\n foo\n " + :| [TextBlock "\n This is the prompt for the second test:\n foo\n "] + ) + Nothing + Nothing + Nothing + Map.empty + ] + , testCase "formats image_url blocks" $ do + let base64Image = "iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAA" + otherBase64Image = "other_iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAA" + template = + fromMessages + [ templateMessage System "You are an AI assistant named {name}." + , contentMessage + User + [ TextPromptBlock FString "What's in this image?" + , ImagePromptBlock FString $ + ImageContent (ImageUrl "data:image/jpeg;base64,{my_image}") Nothing Nothing + , ImagePromptBlock FString $ ImageContent (ImageUrl "{my_other_image}") Nothing Nothing + , ImagePromptBlock FString $ ImageContent (ImageUrl "{my_other_image}") (Just "medium") Nothing + , ImagePromptBlock FString $ + ImageContent (ImageUrl "https://www.langchain.com/image.png") Nothing Nothing + ] + ] + variables = Map.fromList [("name", "R2D2"), ("my_image", base64Image), ("my_other_image", otherBase64Image)] + + case formatPrompt template variables of + Left err -> assertFailure $ "Expected image_url prompt, got " <> show err + Right promptValue -> + toMessages promptValue + @?= [ textMessage System "You are an AI assistant named R2D2." + , Message + User + ( TextBlock "What's in this image?" + :| [ ImageBlock $ ImageContent (ImageUrl ("data:image/jpeg;base64," <> base64Image)) Nothing Nothing + , ImageBlock $ ImageContent (ImageUrl otherBase64Image) Nothing Nothing + , ImageBlock $ ImageContent (ImageUrl otherBase64Image) (Just "medium") Nothing + , ImageBlock $ ImageContent (ImageUrl "https://www.langchain.com/image.png") Nothing Nothing + ] + ) + Nothing + Nothing + Nothing + Map.empty + ] + , testCase "formats image_url blocks with detail" $ do + let templateWith templateFormat urlTemplate = + fromMessages + [ contentMessage + User + [ ImagePromptBlock templateFormat $ + ImageContent urlTemplate (Just "low") Nothing + ] + ] + expected = + [ Message + User + ( ImageBlock + (ImageContent (ImageUrl "data:image/png;base64, base64data") (Just "low") Nothing) + :| [] + ) + Nothing + Nothing + Nothing + Map.empty + ] + assertFormats template variables = + case formatPrompt template variables of + Left err -> assertFailure $ "Expected image_url detail prompt, got " <> show err + Right promptValue -> toMessages promptValue @?= expected + + assertFormats + (templateWith FString (ImageUrl "data:{image_type};base64, {image_data}")) + (Map.fromList [("image_type", "image/png"), ("image_data", "base64data")]) + , testCase "rejects nested f-string replacement fields in image_url blocks" $ do + let template = + fromMessages + [ contentMessage + User + [ ImagePromptBlock FString $ + ImageContent (ImageUrl "{img:{img.__class__.__name__}}") Nothing Nothing + ] + ] + case formatPrompt template (Map.singleton "img" "image-url") of + Left err -> + "Nested replacement fields are not allowed" `T.isInfixOf` T.pack (show err) + @? "Expected nested replacement field error" + Right _ -> assertFailure "Expected nested replacement field error" + , testCase "formats image data blocks with metadata" $ do + let metadata = object ["cache_control" .= object ["type" .= ("{cache_type}" :: Text)]] + template = + fromMessages + [ contentMessage + User + [ ImagePromptBlock FString $ + ImageContent (ImageBase64 Nothing "{source_data}") Nothing (Just metadata) + ] + ] + variables = Map.fromList [("cache_type", "ephemeral"), ("source_data", "base64data")] + + case formatPrompt template variables of + Left err -> assertFailure $ "Expected image data prompt, got " <> show err + Right promptValue -> + toMessages promptValue + @?= [ Message + User + ( ImageBlock + ( ImageContent + (ImageBase64 Nothing "base64data") + Nothing + (Just $ object ["cache_control" .= object ["type" .= ("ephemeral" :: Text)]]) + ) + :| [] + ) + Nothing + Nothing + Nothing + Map.empty + ] + , testCase "round-trips rendered image data blocks through json" $ do + let block = ImageBlock $ ImageContent (ImageUrl "https://example.com/image.png") Nothing Nothing + decode (encode block) @?= Just block + ] + +partialTests :: TestTree +partialTests = + testGroup + "partial" + [ testCase "formats chat messages with stored variables" $ do + let template1 = + fromMessages + [ templateMessage System "You are an AI assistant named {name}." + , templateMessage User "Hi I'm {user}" + , templateMessage Assistant "Hi there, {user}, I'm {name}." + , templateMessage User "{input}" + ] + template2 = + partial + template1 + (Map.fromList [("user", PartialText "Lucy"), ("name", PartialText "R2D2")]) + variables = Map.singleton "input" "hello" + expected = + [ textMessage System "You are an AI assistant named R2D2." + , userMessage "Hi I'm Lucy" + , textMessage Assistant "Hi there, Lucy, I'm R2D2." + , userMessage "hello" + ] + expectedString = + T.intercalate + "\n" + [ "System: You are an AI assistant named R2D2." + , "Human: Hi I'm Lucy" + , "AI: Hi there, Lucy, I'm R2D2." + , "Human: hello" + ] + + case formatPrompt template1 variables of + Left _ -> pure () + Right promptValue -> + assertFailure $ "Expected missing variable error, got " <> show promptValue + + case formatPrompt template2 variables of + Left err -> assertFailure $ "Expected formatted prompt, got " <> show err + Right promptValue -> toMessages promptValue @?= expected + format template2 variables @?= Right expectedString + , testCase "formats role template messages with partial variables" $ do + let template = + fromMessages + [ templateMessage System "You are {name}, a {role} assistant." + , templateMessage User "{question}" + ] + partialTemplate = partial template (Map.fromList [("name", PartialText "Alice"), ("role", PartialText "helpful")]) + + inputVariables partialTemplate @?= ["question"] + case formatPrompt partialTemplate (Map.singleton "question" "What is Python?") of + Left err -> assertFailure $ "Expected formatted prompt, got " <> show err + Right promptValue -> + toMessages promptValue + @?= [ textMessage System "You are Alice, a helpful assistant." + , userMessage "What is Python?" + ] + , testCase "infers required variables after partial variables" $ do + let template = + fromMessages + [ templateMessage User "Do something with {question} using {context} giving it like {formatins}" + ] + partialTemplate = partial template (Map.singleton "formatins" (PartialText "some structure")) + + inputVariables partialTemplate @?= ["question", "context"] + , testCase "composes partially initialized messages" $ do + let prompt = + partial + (fromMessages [templateMessage System "Prompt {x} {y}"]) + (Map.singleton "x" (PartialText "1")) + appendix = fromMessages [templateMessage System "Appendix {z}"] + composed = extend prompt (messages appendix) + + case formatPrompt composed (Map.fromList [("y", "2"), ("z", "3")]) of + Left err -> assertFailure $ "Expected formatted prompt, got " <> show err + Right promptValue -> + toMessages promptValue + @?= [ textMessage System "Prompt 1 2" + , textMessage System "Appendix 3" + ] + , testCase "formats messages placeholder with partial messages" $ do + let prompt = fromMessages [messagesPlaceholder "history"] + partialPrompt = partial prompt (Map.singleton "history" (PartialMessages [textMessage System "foo"])) + + inputVariables partialPrompt @?= [] + case formatPrompt partialPrompt Map.empty of + Left err -> assertFailure $ "Expected formatted placeholder, got " <> show err + Right promptValue -> toMessages promptValue @?= [textMessage System "foo"] + + case invoke + partialPrompt + (ChatPromptInputs Map.empty (Map.singleton "history" [textMessage System "bar"])) of + Left err -> assertFailure $ "Expected runtime placeholder override, got " <> show err + Right promptValue -> toMessages promptValue @?= [textMessage System "bar"] + + let optionalPrompt = + fromMessages + [ messagesPlaceholderWithOptions $ + MessagesPlaceholderOptions "history" True Nothing + ] + partialOptionalPrompt = partial optionalPrompt (Map.singleton "history" (PartialMessages [textMessage System "foo"])) + + case formatPrompt optionalPrompt Map.empty of + Left err -> assertFailure $ "Expected empty optional placeholder, got " <> show err + Right promptValue -> toMessages promptValue @?= [] + case formatPrompt partialOptionalPrompt Map.empty of + Left err -> assertFailure $ "Expected formatted optional placeholder, got " <> show err + Right promptValue -> toMessages promptValue @?= [textMessage System "foo"] + ] + +appendExtendTests :: TestTree +appendExtendTests = + testGroup + "append / extend" + [ testCase "appends template messages" $ do + let template = + fromMessages + [templateMessage System "You are helpful."] + template' = append template (templateMessage User "{question}") + + case formatPrompt template' (Map.singleton "question" "What is AI?") of + Left err -> assertFailure $ "Expected formatted prompt, got " <> show err + Right promptValue -> + toMessages promptValue + @?= [ textMessage System "You are helpful." + , userMessage "What is AI?" + ] + , testCase "appends and extends messages" $ do + let message1 = textMessage System "foo" + message2 = userMessage "bar" + message3 = userMessage "baz" + baseTemplate = fromMessages [message message1] + template' = append (append baseTemplate (message message2)) (message message3) + template'' = extend template' [message message2, message message3] + template''' = append template'' (templateMessage System "hello!") + + length (messages template') @?= 3 + length (messages template'') @?= 5 + messages template'' + @?= [ message message1 + , message message2 + , message message3 + , message message2 + , message message3 + ] + case formatPrompt template''' Map.empty of + Left err -> assertFailure $ "Expected formatted prompt, got " <> show err + Right promptValue -> + last (toMessages promptValue) @?= textMessage System "hello!" + ] + +invokeTests :: TestTree +invokeTests = + testGroup + "invoke" + [ testCase "formats chat prompt template messages" $ do + let invokeTemplate = + fromMessages + [ templateMessage System "You are {name}." + , templateMessage User "{question}" + ] + variables = ChatPromptVariables $ Map.fromList [("name", "Alice"), ("question", "Hello?")] + + case invoke invokeTemplate variables of + Left err -> assertFailure $ "Expected formatted prompt, got " <> show err + Right promptValue -> + toMessages promptValue + @?= [ textMessage System "You are Alice." + , userMessage "Hello?" + ] + , testCase "accepts message list input for a single messages placeholder" $ do + let placeholderTemplate = + fromMessages + [messagesPlaceholder "history"] + input = ChatPromptMessageList [userMessage "Hi there"] + + case invoke placeholderTemplate input of + Left err -> assertFailure $ "Expected placeholder prompt value, got " <> show err + Right promptValue -> toMessages promptValue @?= [userMessage "Hi there"] + , testCase "rejects list input for mixed templates" $ do + let mixedPrompt = + fromMessages + [ templateMessage System "You are a {foo}" + , messagesPlaceholder "history" + ] + listInput = ChatPromptMessageList [userMessage "Hi there"] + case invoke mixedPrompt listInput of + Left _ -> pure () + Right promptValue -> + assertFailure $ "Expected list input validation error, got " <> show promptValue + ] + +serializationTests :: TestTree +serializationTests = + testGroup + "serialization" + [ testCase "round-trips messages placeholder and chat prompt" $ do + let placeholder = MessagesPlaceholder "bar" False Nothing + prompt = + fromMessages + [ templateMessage System "foo" + , messagesPlaceholder "bar" + , templateMessage User "baz" + ] + + decode (encode placeholder) @?= Just placeholder + decode (encode prompt) @?= Just prompt + , testCase "round-trips rich chat prompt template" $ do + let prompt = + fromMessages + [ templateMessage System "You are an AI assistant named {name}." + , contentMessage + System + [TextPromptBlock FString "You are an AI assistant named {name}."] + , templateMessage System "you are {foo}" + , contentMessage + User + [ TextPromptBlock FString "hello" + , TextPromptBlock FString "What's in this image?" + , TextPromptBlock FString "What's in this image?" + , ImagePromptBlock FString $ + ImageContent (ImageUrl "data:image/jpeg;base64,{my_image}") Nothing Nothing + , ImagePromptBlock FString $ + ImageContent (ImageUrl "{my_other_image}") Nothing Nothing + , ImagePromptBlock FString $ ImageContent (ImageUrl "{my_other_image}") (Just "medium") Nothing + , ImagePromptBlock FString $ + ImageContent (ImageUrl "https://www.langchain.com/image.png") Nothing Nothing + , ImagePromptBlock FString $ + ImageContent (ImageUrl "data:image/jpeg;base64,foobar") Nothing Nothing + ] + , messagesPlaceholderWithOptions $ MessagesPlaceholderOptions "history" True (Just 3) + , messagesPlaceholder "chat_history" + , messagesPlaceholder "more_history" + ] + + decode (encode prompt) @?= Just prompt + ] + +assertMissingVariable :: (Show err, Show a) => Text -> Either err a -> Assertion +assertMissingVariable expectedFragment result = + case result of + Left err -> + if T.isInfixOf expectedFragment (T.pack (show err)) + then pure () + else assertFailure $ "Expected missing variable error, got " <> show err + Right value -> + assertFailure $ "Expected missing variable error, got " <> show value + +promptVariables :: Map.Map Text Text +promptVariables = Map.fromList [("foo", "foo"), ("bar", "bar"), ("context", "context")] + +withMessagesVariables :: Map.Map Text Text +withMessagesVariables = + Map.fromList [("context", "see"), ("foo", "this"), ("bar", "magic")] + +chatPromptTemplate :: ChatPromptTemplate +chatPromptTemplate = + ChatPromptTemplate + { messages = chatPromptMessages + , inputVariables = ["foo", "bar", "context"] + } + +chatPromptMessages :: [ChatPromptMessage] +chatPromptMessages = + [ templateMessage System "Here's some context: {context}" + , templateMessage User "Hello {foo}, I'm {bar}. Thanks for the {context}" + , templateMessage Assistant "I'm an AI. I'm {foo}. I'm {bar}." + , templateMessage User "I'm a generic message. I'm {foo}. I'm {bar}." + ] + +expectedFormattedPrompt :: Text +expectedFormattedPrompt = + T.intercalate + "\n" + [ "System: Here's some context: context" + , "Human: Hello foo, I'm bar. Thanks for the context" + , "AI: I'm an AI. I'm foo. I'm bar." + , "Human: I'm a generic message. I'm foo. I'm bar." + ] diff --git a/test/Test/Langchain/PromptTemplate/Chat/MessagesPlaceholderSpec.hs b/test/Test/Langchain/PromptTemplate/Chat/MessagesPlaceholderSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/PromptTemplate/Chat/MessagesPlaceholderSpec.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.PromptTemplate.Chat.MessagesPlaceholderSpec (tests) where + +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Core.Error (errorMessage) +import Langchain.Core.Model.Types (Message, assistantMessage, systemMessage, userMessage) +import Langchain.PromptTemplate.Chat (BaseMessagePromptTemplate (..)) +import Langchain.PromptTemplate.Chat.MessagesPlaceholder + ( MessagesPlaceholder + , MessagesPlaceholderOptions (..) + , messagesPlaceholder + , messagesPlaceholderOptions + , messagesPlaceholderWithOptions + ) + +tests :: TestTree +tests = + testGroup + "MessagesPlaceholder" + [ testCase "required placeholder requires its variable" $ do + let result = formatMessages (messagesPlaceholder "history") emptyInputs + case result of + Left err -> + "history" `T.isInfixOf` errorMessage err + @? "Expected error to mention missing history" + Right _ -> assertFailure "Expected missing history to fail" + , testCase "optional placeholder formats to an empty list when omitted" $ + formatMessages optionalPlaceholder emptyInputs + @?= Right [] + , testCase "optional placeholder accepts messages" $ + formatMessages + optionalPlaceholder + ( inputs + [ systemMessage "You are an AI assistant." + , userMessage "Hello!" + ] + ) + @?= Right + [ systemMessage "You are an AI assistant." + , userMessage "Hello!" + ] + , testCase "placeholder without a message limit returns the whole history" $ + let history = map assistantMessage ["1", "2", "3"] + in formatMessages + (messagesPlaceholder "history") + (inputs history) + @?= Right history + , testCase "placeholder with n_messages returns the last messages" $ + let history = map assistantMessage ["1", "2", "3"] + prompt = + messagesPlaceholderWithOptions $ + (messagesPlaceholderOptions "history") {nMessages = Just 2} + in formatMessages + prompt + (inputs history) + @?= Right [assistantMessage "2", assistantMessage "3"] + , testCase "placeholder rejects non-positive n_messages" $ + let history = map assistantMessage ["1", "2", "3"] + prompt = + messagesPlaceholderWithOptions $ + (messagesPlaceholderOptions "history") {nMessages = Just 0} + in case formatMessages prompt (inputs history) of + Left err -> + "n_messages" `T.isInfixOf` errorMessage err + @? "Expected error to mention n_messages" + Right _ -> assertFailure "Expected non-positive n_messages to fail" + ] + +optionalPlaceholder :: MessagesPlaceholder +optionalPlaceholder = + messagesPlaceholderWithOptions $ + (messagesPlaceholderOptions "history") {optional = True} + +emptyInputs :: Map.Map T.Text [Message] +emptyInputs = Map.empty + +inputs :: [Message] -> Map.Map T.Text [Message] +inputs history = Map.fromList [("history", history)] diff --git a/test/Test/Langchain/PromptTemplate/FewShotSpec.hs b/test/Test/Langchain/PromptTemplate/FewShotSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/PromptTemplate/FewShotSpec.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.PromptTemplate.FewShotSpec (tests) where + +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.PromptTemplate.FewShot + +tests :: TestTree +tests = + testGroup + "FewShotPromptTemplate" + [ testCase "correctly formats a few-shot prompt" $ + let expected = + "Examples of {type}:\nInput: Hello\nOutput: Bonjour\n\nInput: Goodbye\nOutput: Au revoir\nNow translate: {query}" + in renderFewShotPrompt fewShotTemplate @?= Right expected + , testCase "handles empty examples list" $ + let emptyExamples = fewShotTemplate {fsExamples = []} + in renderFewShotPrompt emptyExamples @?= Right "Examples of {type}:\n\nNow translate: {query}" + , testCase "handles empty prefix and suffix" $ + let noPreSuf = fewShotTemplate {fsPrefix = "", fsSuffix = ""} + in renderFewShotPrompt noPreSuf + @?= Right "Input: Hello\nOutput: Bonjour\n\nInput: Goodbye\nOutput: Au revoir" + , testCase "returns an error when example variables are missing" $ + let badExamples = + fewShotTemplate + { fsExamples = [Map.fromList [("wrong", "value")]] + , fsExampleTemplate = "{input} translates to {output}" + } + in case renderFewShotPrompt badExamples of + Left err -> + "input" `T.isInfixOf` T.pack (show err) + @? "Expected error to contain 'input'" + Right _ -> + assertFailure + "Expected an error for missing example variable" + , testCase "correctly uses the example separator" $ + let customSep = fewShotTemplate {fsExampleSeparator = " ### "} + in renderFewShotPrompt customSep + @?= Right + "Examples of {type}:\nInput: Hello\nOutput: Bonjour ### Input: Goodbye\nOutput: Au revoir\nNow translate: {query}" + , testCase "renderFewShotPromptWithVars interpolates full template" $ do + let inputVars = Map.fromList [("type", "Spanish"), ("query", "Thank you")] + expected = + "Examples of Spanish:\nInput: Hello\nOutput: Bonjour\n\nInput: Goodbye\nOutput: Au revoir\nNow translate: Thank you" + renderFewShotPromptWithVars fewShotTemplate inputVars @?= Right expected + ] + where + fewShotTemplate = + FewShotPromptTemplate + { fsPrefix = "Examples of {type}:\n" + , fsExamples = + [ Map.fromList [("input", "Hello"), ("output", "Bonjour")] + , Map.fromList [("input", "Goodbye"), ("output", "Au revoir")] + ] + , fsExampleTemplate = "Input: {input}\nOutput: {output}" + , fsExampleSeparator = "\n\n" + , fsSuffix = "\nNow translate: {query}" + } diff --git a/test/Test/Langchain/PromptTemplate/PromptSpec.hs b/test/Test/Langchain/PromptTemplate/PromptSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/PromptTemplate/PromptSpec.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.PromptTemplate.PromptSpec (tests) where + +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.PromptTemplate.Prompt + +tests :: TestTree +tests = + testGroup + "PromptTemplate" + [ testCase "correctly interpolates all variables" $ + renderPrompt greetingTemplate vars @?= Right "Hello, Alice! Welcome to Wonderland." + , testCase "handles templates with no variables" $ + let noVarTemplate = fromTemplate "Hello, world!" + in renderPrompt noVarTemplate Map.empty @?= Right "Hello, world!" + , testCase "handles templates with repeated variables" $ + let repeatTemplate = fromTemplate "{name} likes {food}. {name} eats {food} every day." + repeatVars = Map.fromList [("name", "Bob"), ("food", "pizza")] + in renderPrompt repeatTemplate repeatVars @?= Right "Bob likes pizza. Bob eats pizza every day." + , testCase "returns an error for missing variables" $ + let missingVars = Map.fromList [("name", "Charlie")] + in case renderPrompt greetingTemplate missingVars of + Left err -> "place" `T.isInfixOf` T.pack (show err) @? "Expected error to contain 'place'" + Right _ -> assertFailure "Expected an error for missing variable" + , testCase "renders escaped f-string braces" $ + let promptTemplate = fromTemplate "Hello {{name}}, {name}!" + in renderPrompt promptTemplate (Map.singleton "name" "Alice") @?= Right "Hello {name}, Alice!" + , testCase "renders f-string format specs" $ + let promptTemplate = fromTemplate "Hello, {name:~u}!" + in renderPrompt promptTemplate (Map.singleton "name" "Alice") @?= Right "Hello, ALICE!" + , testCase "infers f-string variables without escaped braces" $ + let promptTemplate = fromTemplate "Hello {{name}}, {name}!" + in inputVariables promptTemplate @?= ["name"] + , testCase "rejects f-string positional fields" $ + assertRenderErrorContains "Positional arguments are not supported" $ + renderPrompt (fromTemplate "Hello, {0}!") (Map.singleton "0" "Alice") + , testCase "rejects f-string attribute access" $ + assertRenderErrorContains "Attribute access is not supported" $ + renderPrompt (fromTemplate "Hello, {user.name}!") (Map.singleton "user.name" "Alice") + , testCase "rejects nested f-string replacement fields" $ + assertRenderErrorContains "Nested replacement fields are not allowed" $ + renderPrompt + (fromTemplate "Hello, {name:{width}}!") + (Map.fromList [("name", "Alice"), ("width", "10")]) + ] + where + greetingTemplate = fromTemplate "Hello, {name}! Welcome to {place}." + vars = Map.fromList [("name", "Alice"), ("place", "Wonderland")] + +assertRenderErrorContains :: (Show err) => T.Text -> Either err T.Text -> Assertion +assertRenderErrorContains expected result = + case result of + Left err -> expected `T.isInfixOf` T.pack (show err) @? "Expected error to contain expected text" + Right _ -> assertFailure "Expected render error" diff --git a/test/Test/Langchain/Property/CheckpointerSpec.hs b/test/Test/Langchain/Property/CheckpointerSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Property/CheckpointerSpec.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Property.CheckpointerSpec (tests) where + +import qualified Data.Text as T +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck + +import Langchain.Graph.Checkpointer + +newtype SafeThreadId = SafeThreadId T.Text + deriving (Show, Eq) + +instance Arbitrary SafeThreadId where + arbitrary = SafeThreadId . T.pack <$> listOf1 (elements ['a' .. 'z']) + +newtype SafeState = SafeState T.Text + deriving (Show, Eq) + +instance Arbitrary SafeState where + arbitrary = SafeState . T.pack <$> listOf1 (elements (['a' .. 'z'] ++ ['0' .. '9'] ++ " ")) + +tests :: TestTree +tests = + testGroup + "Langchain.Property.CheckpointerSpec (QuickCheck)" + [ testProperty "MemoryCheckpointer Save-Load Identity: load after save returns saved state" $ + \(SafeThreadId tid) (SafeState stateVal) -> ioProperty $ do + cp <- newMemoryCheckpointer + _ <- saveCheckpoint cp tid "step-1" stateVal + res <- loadCheckpoint cp tid "step-1" + pure (res === Right (Just stateVal)) + , testProperty "MemoryCheckpointer Overwrite: save second state updates checkpoint" $ + \(SafeThreadId tid) (SafeState s1) (SafeState s2) -> ioProperty $ do + cp <- newMemoryCheckpointer + _ <- saveCheckpoint cp tid "step-1" s1 + _ <- saveCheckpoint cp tid "step-1" s2 + res <- loadCheckpoint cp tid "step-1" + pure (res === Right (Just s2)) + , testProperty "MemoryCheckpointer Non-existent thread returns Nothing" $ + \(SafeThreadId tid) -> ioProperty $ do + cp <- newMemoryCheckpointer + res <- loadCheckpoint cp (tid <> "-nonexistent") "step-1" + pure (res === Right (Nothing :: Maybe T.Text)) + , testProperty "SQLiteCheckpointer Save-Load Invariant" $ + \(SafeThreadId tid) (SafeState stateVal) -> ioProperty $ do + withSystemTempDirectory "sqlite-prop-test" $ \tmpDir -> do + let dbFile = tmpDir "checkpoints.db" + cp <- newSQLiteCheckpointer dbFile + _ <- saveCheckpoint cp tid "step-1" stateVal + res <- loadCheckpoint cp tid "step-1" + pure (res === Right (Just stateVal)) + ] diff --git a/test/Test/Langchain/Property/ErrorSpec.hs b/test/Test/Langchain/Property/ErrorSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Property/ErrorSpec.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Test.Langchain.Property.ErrorSpec (tests) where + +import Data.Aeson (decode, encode) +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck + +import Langchain.Core.Error + +instance Arbitrary ErrorContext where + arbitrary = do + comp <- T.pack <$> listOf1 (elements ['a' .. 'z']) + op <- T.pack <$> listOf1 (elements ['a' .. 'z']) + pure $ ErrorContext comp op (posixSecondsToUTCTime 1700000000) Map.empty + +instance Arbitrary LangchainError where + arbitrary = do + msg <- T.pack <$> listOf1 (elements (['a' .. 'z'] ++ ['0' .. '9'] ++ " ,.-")) + mbCtx <- oneof [pure Nothing, Just <$> arbitrary] + elements + [ LLMError msg mbCtx + , AgentError msg mbCtx + , MemoryError msg mbCtx + , ToolError msg mbCtx + , VectorStoreError msg mbCtx + , DocumentLoaderError msg mbCtx + , EmbeddingError msg mbCtx + , RunnableError msg mbCtx + , ParsingError msg mbCtx + , NetworkError msg mbCtx + , ConfigurationError msg mbCtx + , ValidationError msg mbCtx + , InternalError msg mbCtx + ] + +tests :: TestTree +tests = + testGroup + "Langchain.Property.ErrorSpec (QuickCheck)" + [ testProperty "LangchainError JSON round-trip: decode (encode err) == Just err" $ + \err -> decode (encode (err :: LangchainError)) === Just err + ] diff --git a/test/Test/Langchain/Property/MessageSpec.hs b/test/Test/Langchain/Property/MessageSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Property/MessageSpec.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Test.Langchain.Property.MessageSpec (tests) where + +import Data.Aeson (decode, encode, toJSON) +import qualified Data.ByteString as BS +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck + +import Langchain.Core.Model + +-- Arbitrary instances for Core Message types + +instance Arbitrary Role where + arbitrary = elements [System, User, Assistant, Tool, Developer, Function] + +instance Arbitrary ContentBlock where + arbitrary = + oneof + [ TextBlock . T.pack + <$> listOf1 (elements (['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ " \t\n.,!?-")) + , ImageBlock + <$> ( ImageContent + <$> ( ImageBase64 . Just + <$> elements ["image/png", "image/jpeg", "image/webp"] + <*> (T.pack <$> listOf1 (elements ['a' .. 'z'])) + ) + <*> pure Nothing + <*> pure Nothing + ) + , AudioBlock <$> elements ["audio/mp3", "audio/wav"] <*> (T.pack <$> listOf1 (elements ['a' .. 'z'])) + , DataBlock . BS.pack <$> listOf1 arbitrary + ] + +instance Arbitrary ToolCall where + arbitrary = do + tcId <- T.pack <$> listOf1 (elements ['a' .. 'z']) + name <- T.pack <$> listOf1 (elements ['a' .. 'z']) + pure $ ToolCall tcId "function" name (toJSON ("{}" :: Text)) + +instance Arbitrary Message where + arbitrary = do + r <- arbitrary + blocks <- listOf1 arbitrary + let neBlocks = NonEmpty.fromList blocks + mbName <- oneof [pure Nothing, Just . T.pack <$> listOf1 (elements ['a' .. 'z'])] + mbToolId <- oneof [pure Nothing, Just . T.pack <$> listOf1 (elements ['a' .. 'z'])] + pure $ + Message r neBlocks mbName Nothing mbToolId (Map.singleton "example" $ toJSON ("value" :: Text)) + +tests :: TestTree +tests = + testGroup + "Langchain.Property.MessageSpec (QuickCheck)" + [ testProperty "Role JSON round-trip: decode (encode r) == Just r" $ + \r -> decode (encode (r :: Role)) === Just r + , testProperty "ContentBlock JSON round-trip: decode (encode cb) == Just cb" $ + \cb -> decode (encode (cb :: ContentBlock)) === Just cb + , testProperty "Message JSON round-trip: decode (encode msg) == Just msg" $ + \msg -> decode (encode (msg :: Message)) === Just msg + , testProperty "extractMessageText preserves text block contents" $ + \t -> + let txt = T.pack t + msg = userMessage txt + in extractMessageText msg === txt + ] diff --git a/test/Test/Langchain/Property/PromptTemplateSpec.hs b/test/Test/Langchain/Property/PromptTemplateSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Property/PromptTemplateSpec.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Property.PromptTemplateSpec (tests) where + +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck + +import Langchain.PromptTemplate.FewShot +import Langchain.PromptTemplate.Prompt + +-- QuickCheck helper to generate safe variable names [a-z]+ +newtype SafeVar = SafeVar Text + deriving (Show, Eq) + +instance Arbitrary SafeVar where + arbitrary = SafeVar . T.pack <$> listOf1 (elements ['a' .. 'z']) + +-- Safe text without braces +newtype PlainText = PlainText Text + deriving (Show, Eq) + +instance Arbitrary PlainText where + arbitrary = PlainText . T.pack <$> listOf1 (elements (['a' .. 'z'] ++ ['0' .. '9'] ++ " ,.!-")) + +tests :: TestTree +tests = + testGroup + "Langchain.Property.PromptTemplateSpec (QuickCheck)" + [ testProperty "Static templates without braces render unchanged" $ + \(PlainText txt) -> + renderPrompt (fromTemplate txt) Map.empty === Right txt + , testProperty "Single variable interpolation replaces {var} with value" $ + \(SafeVar var) (PlainText val) -> + let tmpl = "Hello {" <> var <> "}!" + vars = Map.singleton var val + expected = "Hello " <> val <> "!" + in renderPrompt (fromTemplate tmpl) vars === Right expected + , testProperty "Missing variable causes render error" $ + \(SafeVar var) -> + let tmpl = "Prefix {" <> var <> "} Suffix" + vars = Map.empty + in case renderPrompt (fromTemplate tmpl) vars of + Left _ -> property True + Right _ -> property False + , testProperty "Two variable interpolation succeeds when all vars present" $ + \(SafeVar v1) (SafeVar v2) (PlainText val1) (PlainText val2) -> + v1 /= v2 ==> + let tmpl = "{" <> v1 <> "} and {" <> v2 <> "}" + vars = Map.fromList [(v1, val1), (v2, val2)] + expected = val1 <> " and " <> val2 + in renderPrompt (fromTemplate tmpl) vars === Right expected + , testProperty "FewShotPromptTemplate renders all examples" $ + \(PlainText prefix) (PlainText suffix) (PlainText ex1) (PlainText ex2) -> + let examples = + [ Map.singleton "content" ex1 + , Map.singleton "content" ex2 + ] + fewShot = + FewShotPromptTemplate + { fsPrefix = prefix + , fsExamples = examples + , fsExampleTemplate = "Ex: {content}" + , fsExampleSeparator = "\n" + , fsSuffix = suffix + } + in case renderFewShotPrompt fewShot of + Right rendered -> + property (prefix `T.isInfixOf` rendered && suffix `T.isInfixOf` rendered) + Left _ -> property False + ] diff --git a/test/Test/Langchain/Property/RunnableSpec.hs b/test/Test/Langchain/Property/RunnableSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Property/RunnableSpec.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Property.RunnableSpec (tests) where + +import Control.Monad.Except (ExceptT, runExceptT) +import Data.Text (Text) +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck + +import Langchain.Core.Error +import Langchain.Core.Runnable + +type PureMonad = ExceptT LangchainError IO + +tests :: TestTree +tests = + testGroup + "Langchain.Property.RunnableSpec (QuickCheck)" + [ testProperty "Left Identity: Id |>> t(x) == t(x)" $ + \n -> ioProperty $ do + let step :: RunnableTree PureMonad Int Int + step = runLambda (\i -> pure $ Right (i * 2)) + pipeline = Id |>> step + res1 <- runExceptT $ interpret pipeline n + res2 <- runExceptT $ interpret step n + pure (res1 === res2) + , testProperty "Right Identity: t(x) |>> Id == t(x)" $ + \n -> ioProperty $ do + let step :: RunnableTree PureMonad Int Int + step = runLambda (\i -> pure $ Right (i + 10)) + pipeline = step |>> Id + res1 <- runExceptT $ interpret pipeline n + res2 <- runExceptT $ interpret step n + pure (res1 === res2) + , testProperty "Associativity: ((f |>> g) |>> h) == (f |>> (g |>> h))" $ + \n -> ioProperty $ do + let f :: RunnableTree PureMonad Int Int + f = runLambda (\i -> pure $ Right (i + 1)) + g :: RunnableTree PureMonad Int Int + g = runLambda (\i -> pure $ Right (i * 3)) + h :: RunnableTree PureMonad Int Int + h = runLambda (\i -> pure $ Right (i - 5)) + + p1 = (f |>> g) |>> h + p2 = f |>> (g |>> h) + res1 <- runExceptT $ interpret p1 n + res2 <- runExceptT $ interpret p2 n + pure (res1 === res2) + , testProperty "Branch selects correct branch based on predicate" $ + \n -> ioProperty $ do + let isPositive :: Int -> PureMonad Bool + isPositive i = pure (i > 0) + thenBranch :: RunnableTree PureMonad Int Text + thenBranch = runLambda (\_ -> pure $ Right "POSITIVE") + elseBranch :: RunnableTree PureMonad Int Text + elseBranch = runLambda (\_ -> pure $ Right "NON-POSITIVE") + branchTree = Branch isPositive thenBranch elseBranch + res <- runExceptT $ interpret branchTree n + let expected = if n > 0 then Right "POSITIVE" else Right "NON-POSITIVE" + pure (res === expected) + , testProperty "Fallback executes fallback branch on primary error" $ + \n -> ioProperty $ do + let failingTree :: RunnableTree PureMonad Int Int + failingTree = runLambda (\_ -> pure $ Left $ internalError "Failed" Nothing Nothing) + fallbackTree :: RunnableTree PureMonad Int Int + fallbackTree = runLambda (\i -> pure $ Right (i + 100)) + pipeline = Fallback failingTree fallbackTree + res <- runExceptT $ interpret pipeline n + pure (res === Right (n + 100)) + , testProperty "Parallel composition (&>&) produces pair output" $ + \n -> ioProperty $ do + let doubleStep :: RunnableTree PureMonad Int Int + doubleStep = runLambda (\i -> pure $ Right (i * 2)) + tripleStep :: RunnableTree PureMonad Int Int + tripleStep = runLambda (\i -> pure $ Right (i * 3)) + parallelTree = doubleStep &>& tripleStep + res <- runExceptT $ interpret parallelTree n + pure (res === Right (n * 2, n * 3)) + ] diff --git a/test/Test/Langchain/Property/TextSplitterSpec.hs b/test/Test/Langchain/Property/TextSplitterSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Property/TextSplitterSpec.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Property.TextSplitterSpec (tests) where + +import Data.Int (Int64) +import qualified Data.Text.Lazy as TL +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck + +import Langchain.TextSplitter.Character + +newtype SplitterText = SplitterText TL.Text + deriving (Show, Eq) + +instance Arbitrary SplitterText where + arbitrary = do + paragraphs <- listOf1 (listOf1 (elements (['a' .. 'z'] ++ ['0' .. '9'] ++ " "))) + pure $ SplitterText $ TL.pack $ unlines paragraphs + +newtype PositiveChunkSize = PositiveChunkSize Int64 + deriving (Show, Eq) + +instance Arbitrary PositiveChunkSize where + arbitrary = PositiveChunkSize . fromIntegral <$> chooseInt (10, 200) + +tests :: TestTree +tests = + testGroup + "Langchain.Property.TextSplitterSpec (QuickCheck)" + [ testProperty "Empty text splits into empty list" $ + \(PositiveChunkSize cSize) -> + let ops = defaultCharacterSplitterOps {chunkSize = cSize} + in splitText ops "" === [] + , testProperty "No chunk exceeds chunkSize" $ + \(PositiveChunkSize cSize) (SplitterText txt) -> + let ops = defaultCharacterSplitterOps {chunkSize = cSize} + chunks = splitText ops txt + in property (all (\c -> TL.length c <= cSize) chunks) + , testProperty "All generated chunks are non-empty" $ + \(PositiveChunkSize cSize) (SplitterText txt) -> + let ops = defaultCharacterSplitterOps {chunkSize = cSize} + chunks = splitText ops txt + in property (not (any TL.null chunks)) + , testProperty "Single character chunks never exceed chunkSize 1" $ + \() -> + let ops = defaultCharacterSplitterOps {chunkSize = 1, separator = ""} + chunks = splitText ops "abcdef" + in property (all (\c -> TL.length c <= 1) chunks) + ] diff --git a/test/Test/Langchain/Provider/FixturesSpec.hs b/test/Test/Langchain/Provider/FixturesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Provider/FixturesSpec.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Provider.FixturesSpec (tests) where + +import Data.Aeson (Value, decode) +import qualified Data.ByteString.Lazy as LBS +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Core.Model +import Langchain.Core.Stream (TokenUsage (..)) +import Langchain.Provider.Gemini (parseGeminiResponse) +import Langchain.Provider.OpenAI (parseOpenAIResponse) + +loadFixture :: FilePath -> IO (Either String Value) +loadFixture fp = do + content <- LBS.readFile fp + case decode content of + Nothing -> pure $ Left ("Failed to decode JSON from fixture: " ++ fp) + Just val -> pure $ Right val + +tests :: TestTree +tests = + testGroup + "Langchain.Provider.FixturesSpec" + [ testCase "Parse OpenAI Chat Completion fixture" $ do + eVal <- loadFixture "test/fixtures/openai_chat_response.json" + case eVal of + Left err -> assertFailure err + Right val -> case parseOpenAIResponse val of + Left parseErr -> assertFailure ("OpenAI parser error: " ++ parseErr) + Right (msg, mbUsage) -> do + messageRole msg @?= Assistant + extractMessageText msg @?= "Hello! I am OpenAI GPT-4o." + case mbUsage of + Nothing -> assertFailure "Expected TokenUsage in response" + Just usage -> promptTokens usage @?= 9 + , testCase "Parse OpenAI Tool Call fixture" $ do + eVal <- loadFixture "test/fixtures/openai_tool_call.json" + case eVal of + Left err -> assertFailure err + Right val -> case parseOpenAIResponse val of + Left parseErr -> assertFailure ("OpenAI parser error: " ++ parseErr) + Right (msg, _) -> do + messageRole msg @?= Assistant + case messageToolCalls msg of + Just [tc] -> do + toolCallName tc @?= "calculator" + toolCallId tc @?= "call_abc123" + _ -> assertFailure "Expected tool call in OpenAI message" + , testCase "Parse Gemini Chat fixture" $ do + eVal <- loadFixture "test/fixtures/gemini_response.json" + case eVal of + Left err -> assertFailure err + Right val -> case parseGeminiResponse val of + Left parseErr -> assertFailure ("Gemini parser error: " ++ parseErr) + Right msg -> do + messageRole msg @?= Assistant + extractMessageText msg @?= "Hello! I am Google Gemini 2.5." + ] diff --git a/test/Test/Langchain/Provider/Gemini.hs b/test/Test/Langchain/Provider/Gemini.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Provider/Gemini.hs @@ -0,0 +1,676 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Langchain.Provider.Gemini (tests) where + +import Control.Concurrent (newEmptyMVar, putMVar, takeMVar) +import Control.Concurrent.Async (async, poll, wait) +import Control.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVarIO) +import Control.Monad (forM, void) +import Control.Monad.Except (runExceptT) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (runResourceT) +import qualified Data.Aeson as Aeson +import Data.Aeson.QQ (aesonQQ) +import qualified Data.ByteString.Lazy as LBS +import Data.Conduit (await, runConduit, (.|)) +import qualified Data.Conduit.Combinators as C +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, isJust, isNothing) +import qualified Data.Text as T +import Network.HTTP.Types (hContentType, status200, status500) +import Network.Wai + ( Application + , Request + , rawPathInfo + , rawQueryString + , requestMethod + , responseLBS + , strictRequestBody + ) +import System.Environment (lookupEnv) +import System.Timeout (timeout) +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Core.Error (LangchainError) +import Langchain.Core.Model +import Langchain.Core.Stream (StreamEvent (..), TokenUsage (..), collectEvents) +import Langchain.Core.Tool (Tool, createTool) +import qualified Langchain.Core.Tool as CoreTool +import Langchain.Provider.Gemini +import Langchain.Tool.Binding (ToolBinder (bindToolsConfig)) +import Test.Langchain.Provider.TestSseServer + ( cancellationAwareSseServer + , capturingRawSseRequestServer + , collectModelStream + , gatedSseServer + , rawSseServer + , sseFrame + , withTestApplication + ) + +withGeminiProvider :: T.Text -> (Gemini -> IO a) -> IO a +withGeminiProvider url action = action $ newGemini "test-key" "test-model" (Just url) + +withRawTestProvider :: [LBS.ByteString] -> (Gemini -> IO a) -> IO a +withRawTestProvider frames action = + withTestApplication (rawSseServer frames) $ \url -> withGeminiProvider url action + +withGatedProvider :: IO () -> (Gemini -> IO a) -> IO a +withGatedProvider waitForContinuation action = + withTestApplication + (gatedSseServer (sseFrame $ chunk "Hel") waitForContinuation [sseFrame $ chunk "lo"]) + $ \url -> withGeminiProvider url action + +withCancellationAwareProvider :: IO () -> (Gemini -> IO a) -> IO a +withCancellationAwareProvider signalClientClosed action = + withTestApplication (cancellationAwareSseServer (sseFrame $ chunk "Hello") signalClientClosed) $ \url -> + withGeminiProvider url action + +errorServer :: Application +errorServer _request respond = respond $ responseLBS status500 [] "" + +capturingGenerateContentServer :: (Request -> LBS.ByteString -> IO ()) -> Application +capturingGenerateContentServer capture request respond = do + body <- strictRequestBody request + capture request body + respond $ + responseLBS + status200 + [(hContentType, "application/json")] + "{\"candidates\":[{\"content\":{\"parts\":[{\"text\":\"ok\"}]}}]}" + +collectRawStream :: [LBS.ByteString] -> IO (Either LangchainError [StreamEvent]) +collectRawStream frames = + withRawTestProvider frames $ \provider -> + collectModelStream provider [userMessage "Hello"] Nothing + +chunk :: LBS.ByteString -> LBS.ByteString +chunk content = + "{\"candidates\":[{\"index\":0,\"content\":{\"parts\":[{\"text\":\"" + <> content + <> "\"}]}}]}" + +tests :: TestTree +tests = + testGroup + "Langchain.Provider.Gemini" + [ testCase "newGemini initializes provider with model" $ do + let p = newGemini "ai-key" "gemini-1.5-pro" Nothing + model p @?= "gemini-1.5-pro" + , testGroup + "invoke" + [ testCase "invoke sends Gemini function declarations" $ do + let weatherTool :: Tool IO + weatherTool = createTool "get_weather" "Gets the weather" weatherSchema (const . pure $ Right "sunny") + capturedRequest <- newEmptyMVar + withTestApplication + (capturingGenerateContentServer (curry . putMVar $ capturedRequest)) + $ \url -> + withGeminiProvider url $ \provider -> do + let tools = bindToolsConfig @Gemini [weatherTool] Nothing + result <- runExceptT $ invoke provider [userMessage "Hello"] tools + case result of + Left err -> assertFailure $ "Expected invoke success, got: " ++ show err + Right response -> extractMessageText response @?= "ok" + (request, body) <- takeMVar capturedRequest + requestMethod request @?= "POST" + rawPathInfo request @?= "/v1beta/models/test-model:generateContent" + rawQueryString request @?= "?key=test-key" + Aeson.decode body + @?= Just + [aesonQQ| + { + "contents": [{"role": "user", "parts": [{"text": "Hello"}]}], + "tools": [{"functionDeclarations": [{ + "name": "get_weather", + "description": "Gets the weather", + "parameters": { + "type": "OBJECT", + "properties": {"city": {"type": "STRING"}}, + "required": ["city"] + } + }]}] + } + |] + , testCase "invoke rejects a non-object Gemini config" $ do + let gemini = newGemini "test-key" "test-model" Nothing + modelConfig = Just $ Aeson.String "invalid" + result <- runExceptT $ invoke gemini [userMessage "Hello"] modelConfig + case result of + Left err -> + assertBool "Expected config error" $ + "Gemini config must be a JSON object" `T.isInfixOf` T.pack (show err) + Right _ -> assertFailure "Expected invalid config to fail" + , testCase "parseGeminiResponse preserves function calls, text, and thought signatures" $ do + let response = + [aesonQQ| + { + "candidates": [ + { + "content": { + "parts": [ + { "text": "Checking weather" }, + { + "thoughtSignature": "signature_1", + "functionCall": { + "id": "call_1", + "name": "get_weather", + "args": { "city": "Paris" } + } + } + ] + } + } + ] + } + |] + expectedCall = ToolCall "call_1" "function" "get_weather" [aesonQQ|{"city": "Paris"}|] + case parseGeminiResponse response of + Left err -> assertFailure $ "Expected function call response, got: " ++ err + Right message -> do + extractMessageText message @?= "Checking weather" + messageToolCalls message @?= Just [expectedCall] + Map.lookup "langchain.gemini.thoughtSignatures" (messageMetadata message) + @?= Just (Aeson.toJSON [Just ("signature_1" :: T.Text)]) + , testCase "parseGeminiResponse leaves ordinary message metadata empty" $ do + let response = [aesonQQ|{"candidates": [{"content": {"parts": [{"text": "ok"}]}}]}|] + case parseGeminiResponse response of + Left err -> assertFailure $ "Expected text response, got: " ++ err + Right message -> messageMetadata message @?= Map.empty + , testCase "invoke replays Gemini thought signatures on function calls" $ do + let toolCall = ToolCall "call_1" "function" "get_weather" [aesonQQ|{"city": "Paris"}|] + assistant = + (assistantMessage "") + { messageToolCalls = Just [toolCall] + , messageMetadata = + Map.singleton + "langchain.gemini.thoughtSignatures" + (Aeson.toJSON [Just ("signature_1" :: T.Text)]) + } + capturedRequest <- newEmptyMVar + withTestApplication + (capturingGenerateContentServer (curry . putMVar $ capturedRequest)) + $ \url -> + withGeminiProvider url $ \provider -> do + result <- runExceptT $ invoke provider [assistant] Nothing + case result of + Left err -> assertFailure $ "Expected invoke success, got: " ++ show err + Right _ -> pure () + (_, body) <- takeMVar capturedRequest + Aeson.decode body + @?= Just + [aesonQQ| + { + "contents": [{"role": "model", "parts": [{ + "thoughtSignature": "signature_1", + "functionCall": { + "id": "call_1", "name": "get_weather", "args": {"city": "Paris"} + } + }]}] + } + |] + , testCase "invoke replays thought signatures for their matching Gemini function calls" $ do + let response = + [aesonQQ| + { + "candidates": [{ + "content": { + "parts": [ + { + "functionCall": + { + "id": "call_weather", + "name": "get_weather", + "args": { + "city": "Paris" + } + } + }, + { + "thoughtSignature": "signature_time", + "functionCall": { + "id": "call_time", + "name": "get_time", + "args": { + "zone": "UTC" + } + } + } + ] + } + }] + } + |] + assistant <- case parseGeminiResponse response of + Left err -> assertFailure ("Expected function call response, got: " ++ err) >> fail "unreachable" + Right message -> return message + capturedRequest <- newEmptyMVar + withTestApplication + (capturingGenerateContentServer (curry . putMVar $ capturedRequest)) + $ \url -> + withGeminiProvider url $ \provider -> do + result <- runExceptT $ invoke provider [assistant] Nothing + case result of + Left err -> assertFailure $ "Expected invoke success, got: " ++ show err + Right _ -> return () + (_, body) <- takeMVar capturedRequest + Aeson.decode body + @?= Just + [aesonQQ| + { + "contents": [ + { + "role": "model", + "parts": [ + { + "functionCall": { + "id": "call_weather", + "name": "get_weather", + "args": { + "city": "Paris" + } + } + }, + { + "thoughtSignature": "signature_time", + "functionCall": { + "id": "call_time", + "name": "get_time", + "args": { + "zone": "UTC" + } + } + } + ] + }] + } + |] + , testCase "invoke omits Gemini thought signatures when metadata is malformed" $ do + let toolCall = ToolCall "call_1" "function" "get_weather" [aesonQQ|{"city": "Paris"}|] + assistant = + (assistantMessage "") + { messageToolCalls = Just [toolCall] + , messageMetadata = Map.singleton "langchain.gemini.thoughtSignatures" (Aeson.String "invalid") + } + capturedRequest <- newEmptyMVar + withTestApplication + (capturingGenerateContentServer (curry . putMVar $ capturedRequest)) + $ \url -> + withGeminiProvider url $ \provider -> do + result <- runExceptT $ invoke provider [assistant] Nothing + case result of + Left err -> assertFailure $ "Expected invoke success, got: " ++ show err + Right _ -> pure () + (_, body) <- takeMVar capturedRequest + Aeson.decode body + @?= Just + [aesonQQ| + { + "contents": [ + { + "role": "model", + "parts": [ + { + "functionCall": { + "id": "call_1", + "name": "get_weather", + "args": { + "city": "Paris" + } + } + }] + } + ] + } + |] + , testCase "invoke groups adjacent Gemini function responses" $ do + let weatherResult = + (toolMessage "Sunny") + { messageName = Just "get_weather" + , messageToolId = Just "call_weather" + } + timeResult = + (toolMessage "12:00") + { messageName = Just "get_time" + , messageToolId = Just "call_time" + } + capturedRequest <- newEmptyMVar + withTestApplication + (capturingGenerateContentServer (curry . putMVar $ capturedRequest)) + $ \url -> + withGeminiProvider url $ \provider -> do + let messages = [userMessage "Weather?", weatherResult, timeResult] + result <- runExceptT $ invoke provider messages Nothing + case result of + Left err -> assertFailure $ "Expected invoke success, got: " ++ show err + Right _ -> return () + (_, body) <- takeMVar capturedRequest + Aeson.decode body + @?= Just + [aesonQQ| + { + "contents": [ + {"role": "user", "parts": [{"text": "Weather?"}]}, + {"role": "user", "parts": [ + {"functionResponse": {"id": "call_weather", "name": "get_weather", "response": {"result": "Sunny"}}}, + {"functionResponse": {"id": "call_time", "name": "get_time", "response": {"result": "12:00"}}} + ]} + ] + } + |] + ] + , testGroup + "stream" + [ testCase "live Gemini stream emits text and usage" $ do + mbApiKey <- lookupEnv "GEMINI_API_KEY" + case mbApiKey of + Nothing -> putStrLn " [SKIPPED] GEMINI_API_KEY is not set" + Just envApiKey -> do + envModel <- fromMaybe "gemini-3.5-flash-lite" <$> lookupEnv "GEMINI_STREAM_TEST_MODEL" + let provider = newGemini (T.pack envApiKey) (T.pack envModel) Nothing + result <- + timeout 60000000 $ + runResourceT . runExceptT . collectEvents $ + stream provider [userMessage "Reply with exactly OK."] Nothing + case result of + Nothing -> assertFailure "Gemini stream timed out" + Just (Left err) -> assertFailure $ "Expected stream success, got: " ++ show err + Just (Right events) -> case reverse events of + LLMEnd _ responseMessage (Just usage) : _ -> do + assertBool "Expected non-empty streamed text" $ not $ T.null $ extractMessageText responseMessage + assertBool "Expected positive total token usage" $ totalTokens usage > 0 + _ -> assertFailure $ "Expected LLMEnd with usage, got: " ++ show events + , testCase "live Gemini stream invokes a tool and continues with its result" $ do + mbApiKey <- lookupEnv "GEMINI_API_KEY" + case mbApiKey of + Nothing -> putStrLn " [SKIPPED] GEMINI_API_KEY is not set" + Just envApiKey -> do + envModel <- fromMaybe "gemini-3.5-flash-lite" <$> lookupEnv "GEMINI_STREAM_TEST_MODEL" + let weatherTool :: Tool IO + weatherTool = + createTool + "get_weather" + "Returns the current weather for a city." + weatherSchema + (const . return $ Right "The weather in Paris is sunny and 22 C.") + provider = newGemini (T.pack envApiKey) (T.pack envModel) Nothing + runLive messages config = + timeout 60000000 $ + runResourceT . runExceptT . collectEvents $ + stream provider messages config + prompt = userMessage "Use get_weather to look up the weather in Paris, then answer using the tool result." + + firstResult <- runLive [prompt] (bindToolsConfig @Gemini [weatherTool] Nothing) + firstEvents <- case firstResult of + Nothing -> assertFailure "Gemini tool-call stream timed out" >> fail "unreachable" + Just (Left err) -> assertFailure ("Expected tool-call stream success, got: " ++ show err) >> fail "unreachable" + Just (Right events) -> pure events + (assistant, toolCalls) <- case reverse firstEvents of + LLMEnd _ responseMessage _ : _ -> case messageToolCalls responseMessage of + Just calls@[toolCall] + | toolCallName toolCall == "get_weather" -> pure (responseMessage, calls) + _ -> assertFailure ("Expected Gemini tool call, got: " ++ show firstEvents) >> fail "unreachable" + _ -> assertFailure ("Expected tool-call stream end, got: " ++ show firstEvents) >> fail "unreachable" + toolResults <- forM toolCalls $ \toolCall -> do + output <- CoreTool.toolExecute weatherTool (toolCallArguments toolCall) + case output of + Left err -> assertFailure ("Tool execution failed: " ++ show err) >> fail "unreachable" + Right text -> + pure $ + (textMessage Tool text) + { messageName = Just (toolCallName toolCall) + , messageToolId = Just (toolCallId toolCall) + } + secondResult <- runLive ([prompt, assistant] <> toolResults) Nothing + case secondResult of + Nothing -> assertFailure "Gemini tool-result stream timed out" + Just (Left err) -> assertFailure $ "Expected tool-result stream success, got: " ++ show err + Just (Right events) -> case reverse events of + LLMEnd _ responseMessage (Just usage) : _ -> do + assertBool "Expected final text after tool result" $ + not $ + T.null $ + extractMessageText responseMessage + assertBool "Expected positive total token usage" $ totalTokens usage > 0 + _ -> assertFailure $ "Expected LLMEnd with usage, got: " ++ show events + , testCase "stream sends Gemini function declarations and function responses" $ do + let weatherTool :: Tool IO + weatherTool = createTool "get_weather" "Gets the weather" weatherSchema (const $ pure $ Right "sunny") + toolCall = + ToolCall + "call_weather" + "function" + "get_weather" + [aesonQQ|{"city": "Paris"}|] + assistant = (assistantMessage "") {messageToolCalls = Just [toolCall]} + toolResult = (toolMessage "Sunny") {messageToolId = Just "call_weather"} + capturedRequest <- newEmptyMVar + withTestApplication + ( capturingRawSseRequestServer + (curry . putMVar $ capturedRequest) + [sseFrame "{}"] + ) + $ \url -> withGeminiProvider url $ \provider -> + void . runResourceT . runExceptT . collectEvents $ + stream + provider + [userMessage "Weather?", assistant, toolResult] + (bindToolsConfig @Gemini [weatherTool] Nothing) + (request, body) <- takeMVar capturedRequest + requestMethod request @?= "POST" + rawPathInfo request @?= "/v1beta/models/test-model:streamGenerateContent" + Aeson.decode body + @?= Just + [aesonQQ| + { + "contents": [ + {"role": "user", "parts": [{"text": "Weather?"}]}, + {"role": "model", "parts": [{"functionCall": { + "id": "call_weather", "name": "get_weather", "args": {"city": "Paris"} + }}]}, + {"role": "user", "parts": [{"functionResponse": { + "id": "call_weather", "name": "get_weather", "response": {"result": "Sunny"} + }}]} + ], + "tools": [{"functionDeclarations": [{ + "name": "get_weather", + "description": "Gets the weather", + "parameters": { + "type": "OBJECT", + "properties": {"city": {"type": "STRING"}}, + "required": ["city"] + } + }]}] + } + |] + , testCase "stream emits incremental text chunks and ends" $ do + result <- collectRawStream [sseFrame $ chunk "Hel", sseFrame $ chunk "lo"] + case result of + Left err -> assertFailure $ "Expected stream success, got: " ++ show err + Right events -> case events of + [LLMStart {}, LLMChunk _ "Hel" Nothing, LLMChunk _ "lo" Nothing, LLMEnd _ responseMessage Nothing] -> + do + extractMessageText responseMessage @?= "Hello" + messageMetadata responseMessage @?= Map.empty + _ -> assertFailure $ "Unexpected stream events: " ++ show events + , testCase "stream emits mixed text and function call chunks" $ do + let frame = + Aeson.encode + [aesonQQ| + { + "candidates": [ + { + "index": 0, + "content": { + "parts": [ + { "text": "Checking weather" }, + { + "thoughtSignature": "signature_1", + "functionCall": { + "id": "call_1", + "name": "get_weather", + "args": { "city": "Paris" } + } + } + ] + } + } + ] + } + |] + expectedCall = ToolCall "call_1" "function" "get_weather" [aesonQQ|{"city": "Paris"}|] + result <- collectRawStream [sseFrame frame] + case result of + Right [LLMStart {}, LLMChunk _ "Checking weather" (Just toolCall), LLMEnd _ responseMessage Nothing] -> do + toolCall @?= expectedCall + extractMessageText responseMessage @?= "Checking weather" + messageToolCalls responseMessage @?= Just [expectedCall] + Map.lookup "langchain.gemini.thoughtSignatures" (messageMetadata responseMessage) + @?= Just (Aeson.toJSON [Just ("signature_1" :: T.Text)]) + Left err -> assertFailure $ "Expected stream success, got: " ++ show err + Right events -> assertFailure $ "Unexpected stream events: " ++ show events + , testCase "stream delivers a chunk before the response completes" $ do + firstChunkReceived <- newEmptyMVar + continueResponse <- newEmptyMVar + receivedEvents <- newTVarIO [] + withGatedProvider (takeMVar continueResponse) $ \provider -> do + consumer <- + async + . runResourceT + . runExceptT + . runConduit + $ stream provider [userMessage "Hello"] Nothing + .| C.mapM_ + ( \event -> do + liftIO . atomically $ modifyTVar' receivedEvents (event :) + case event of + LLMChunk _ "Hel" _ -> liftIO $ putMVar firstChunkReceived () + _ -> pure () + ) + received <- timeout 500000 $ takeMVar firstChunkReceived + assertBool "expected first chunk before releasing the response" $ isJust received + stillStreaming <- poll consumer + assertBool "consumer should wait for the remaining response" $ isNothing stillStreaming + putMVar continueResponse () + result <- timeout 500000 $ wait consumer + case result of + Nothing -> assertFailure "stream did not finish after releasing the response" + Just (Left err) -> assertFailure $ "Expected stream success, got: " ++ show err + Just (Right ()) -> do + events <- reverse <$> readTVarIO receivedEvents + case reverse events of + LLMEnd _ responseMessage Nothing : _ -> extractMessageText responseMessage @?= "Hello" + _ -> assertFailure $ "Expected a completed stream, got: " ++ show events + , testCase "stream finishes when the SSE connection closes" $ do + result <- collectRawStream [sseFrame $ chunk "Hello"] + case result of + Left err -> assertFailure $ "Expected stream success, got: " ++ show err + Right events -> case events of + [LLMStart {}, LLMChunk _ "Hello" Nothing, LLMEnd _ responseMessage Nothing] -> + extractMessageText responseMessage @?= "Hello" + _ -> assertFailure $ "Unexpected stream events: " ++ show events + , testCase "stream converts malformed SSE data to LangchainError" $ do + result <- collectRawStream [sseFrame "not JSON"] + case result of + Left _ -> pure () + Right events -> assertFailure $ "Expected stream failure, got: " ++ show events + , testCase "stream rejects malformed function calls" $ do + result <- + collectRawStream + [ sseFrame $ + Aeson.encode + [aesonQQ| + { + "candidates": [ + { + "content": { + "parts": [ + { + "functionCall": { + "args": {} + } + } + ] + } + } + ] + } + |] + ] + case result of + Left _ -> pure () + Right events -> assertFailure $ "Expected stream failure, got: " ++ show events + , testCase "stream converts HTTP errors to LangchainError" $ do + result <- withTestApplication errorServer $ \url -> + withGeminiProvider url $ \provider -> + runResourceT $ runExceptT $ collectEvents (stream provider [userMessage "Hello"] Nothing) + case result of + Left _ -> pure () + Right events -> assertFailure $ "Expected stream failure, got: " ++ show events + , testCase "stream includes usage metadata on LLMEnd" $ do + let usage = TokenUsage 7 5 12 + frame = + Aeson.encode + [aesonQQ| + { + "candidates": [ + { + "index": 0, + "content": { + "parts": [{"text": "Hello"}] + } + } + ], + "usageMetadata": { + "promptTokenCount": 7, + "candidatesTokenCount": 5, + "totalTokenCount": 12 + } + } + |] + result <- collectRawStream [sseFrame frame] + case result of + Right [LLMStart {}, LLMChunk _ "Hello" Nothing, LLMEnd _ responseMessage (Just actualUsage)] -> do + extractMessageText responseMessage @?= "Hello" + actualUsage @?= usage + Left err -> assertFailure $ "Expected stream success, got: " ++ show err + Right events -> assertFailure $ "Unexpected stream events: " ++ show events + , testCase "stream uses the Gemini SSE endpoint and contents payload" $ do + capturedRequest <- newEmptyMVar + withTestApplication + ( capturingRawSseRequestServer + (curry . putMVar $ capturedRequest) + [sseFrame "{}"] + ) + $ \url -> do + withGeminiProvider url $ \provider -> + void . runResourceT . runExceptT . collectEvents $ stream provider [userMessage "Hello"] Nothing + (request, body) <- takeMVar capturedRequest + requestMethod request @?= "POST" + rawPathInfo request @?= "/v1beta/models/test-model:streamGenerateContent" + rawQueryString request @?= "?alt=sse&key=test-key" + Aeson.decode body + @?= Just + [aesonQQ|{"contents": [{"role": "user", "parts": [{"text": "Hello"}]}]}|] + , testCase "stream closes the SSE connection when the consumer stops after a chunk" $ do + clientClosed <- newEmptyMVar + withCancellationAwareProvider (putMVar clientClosed ()) $ \provider -> do + void . runResourceT . runExceptT . runConduit $ + stream provider [userMessage "Hello"] Nothing .| (await >> await) + closed <- timeout 500000 $ takeMVar clientClosed + assertBool "expected the SSE connection to close" $ isJust closed + ] + ] + where + weatherSchema :: Aeson.Value + weatherSchema = + [aesonQQ| + { + "type": "OBJECT", + "properties": {"city": {"type": "STRING"}}, + "required": ["city"] + } + |] diff --git a/test/Test/Langchain/Provider/Mock.hs b/test/Test/Langchain/Provider/Mock.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Provider/Mock.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module : Test.Langchain.Provider.Mock +Description : Mock chat model provider for testing and deterministic evaluation +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Provides a purely in-memory 'MockModel' implementing 'ChatModel' for testing and offline workflows. +-} +module Test.Langchain.Provider.Mock + ( MockModel (..) + , newMockModel + ) where + +import Data.Aeson (object, (.=)) +import Data.Conduit (yield) +import Data.Text (Text) + +import Langchain.Cache.Core (CacheableChatModel (..)) +import Langchain.Core.Model + ( ChatModel (..) + , assistantMessage + ) +import Langchain.Core.Stream (StreamEvent (..)) +import Langchain.Tool.Binding (ToolBinder (..)) + +-- | Mock model implementation for pure monadic testing. +data MockModel = MockModel + { mockResponse :: Text + , mockModelName :: Text + } + deriving (Eq, Show) + +-- | Construct a MockModel with a default model name +newMockModel :: Text -> MockModel +newMockModel resp = MockModel resp "mock-model" + +instance ChatModel MockModel where + type ModelConfig MockModel = () + + invoke model _ _ = pure $ assistantMessage (mockResponse model) + + stream model inputMsgs _ = do + let rId = "mock-run-id" + yield $ LLMStart rId (mockModelName model) inputMsgs + yield $ LLMChunk rId (mockResponse model) Nothing + yield $ LLMEnd rId (assistantMessage $ mockResponse model) Nothing + +instance ToolBinder MockModel m where + bindToolsConfig _ _ = Nothing + +instance CacheableChatModel MockModel where + cacheModelIdentity (MockModel response mName) _ = + object + [ "provider" .= ("mock" :: Text) + , "model" .= mName + , "response" .= response + ] diff --git a/test/Test/Langchain/Provider/Ollama.hs b/test/Test/Langchain/Provider/Ollama.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Provider/Ollama.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Provider.Ollama (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Control.Monad.Except (runExceptT) +import Data.Text (Text) +import qualified Data.Text as T + +import Langchain.Core.Model +import Langchain.Core.Tool (Tool) +import Langchain.Provider.Ollama +import Langchain.Tool.Calculator (calculatorTool) +import Test.Langchain.TestHelpers (withOllamaModel) + +import qualified Data.List.NonEmpty as NonEmpty +import qualified Ollama.Client as OC +import qualified Ollama.Types.Format as OFormat +import qualified Ollama.Types.Message as O +import qualified Ollama.Types.Tool as OTool + +testModelName :: Text +testModelName = "gemma3:latest" + +tests :: TestTree +tests = + testGroup + "Langchain.Provider.Ollama" + [ testCase "newOllama initializes provider with defaultConfig" $ do + p <- newOllama testModelName defaultConfig + ollamaModelName p @?= testModelName + , testCase "newOllama accepts custom OllamaClientConfig" $ do + let cfg = + defaultConfig + { configBaseUrl = "http://custom-host:11434" + , configTimeout = 120 + } + p <- newOllama "qwen3.5:2b" cfg + ollamaModelName p @?= "qwen3.5:2b" + configBaseUrl (OC.clientConfig (client p)) @?= "http://custom-host:11434" + configTimeout (OC.clientConfig (client p)) @?= 120 + , testCase "newOllamaWithClient wraps existing OllamaClient" $ do + c <- OC.defaultClient + let p = newOllamaWithClient testModelName c + ollamaModelName p @?= testModelName + , testCase "invoke returns Assistant message" $ do + withOllamaModel testModelName $ \modelName -> do + p <- newOllama modelName defaultConfig + let input = [userMessage "What is 2 + 2? Answer with just the number."] + res <- runExceptT $ invoke p input Nothing + case res of + Left err -> assertFailure $ "Expected success, got error: " ++ show err + Right msg -> do + messageRole msg @?= Assistant + assertBool "Should contain 4" ("4" `T.isInfixOf` extractMessageText msg) + , testCase "batch processes multiple inputs" $ do + withOllamaModel testModelName $ \modelName -> do + p <- newOllama modelName defaultConfig + let inputs = [[userMessage "What is 1 + 1?"], [userMessage "What is 2 + 2?"]] + res <- runExceptT $ batch p inputs Nothing + case res of + Left err -> assertFailure $ "Expected success, got error: " ++ show err + Right msgs -> do + length msgs @?= 2 + , testCase "withOptions sets ModelOptions on ChatRequest" $ do + p <- newOllama testModelName defaultConfig + let opts = defaultOptions {optTemperature = Just 0.3, optNumCtx = Just 4096} + req = withOptions opts (chatRequestFor p [userMessage "Hello"]) + case chatOptions req of + Nothing -> assertFailure "Expected chatOptions in ChatRequest" + Just o -> do + optTemperature o @?= Just 0.3 + optNumCtx o @?= Just 4096 + , testCase "toOllamaTool converts calculatorTool to Ollama Tool" $ do + let cTool = calculatorTool :: Tool IO + case toOllamaTool cTool of + Nothing -> assertFailure "Failed to convert calculatorTool to Ollama Tool" + Just ot -> do + OTool.toolType ot @?= "function" + OTool.fnName (OTool.toolFunction ot) @?= "calculator" + , testCase "withTools on ChatRequest sets chatTools" $ do + p <- newOllama testModelName defaultConfig + let req = withTools [calculatorTool :: Tool IO] (chatRequestFor p [userMessage "Hello"]) + case chatTools req of + Nothing -> assertFailure "Expected chatTools in ChatRequest" + Just ts -> length ts @?= 1 + , testCase "chatRequestFor creates base request" $ do + p <- newOllama testModelName defaultConfig + let req = chatRequestFor p [userMessage "Hello"] + chatModel req @?= ModelName testModelName + , testCase "invoke propagates chatFormat from mbReq" $ do + withOllamaModel testModelName $ \modelName -> do + p <- newOllama modelName defaultConfig + let input = [userMessage "Return JSON: {\"answer\": 42}"] + req = withJsonFormat (chatRequestFor p input) + chatFormat req @?= Just OFormat.JsonFormat + res <- runExceptT $ invoke p input (Just req) + case res of + Left err -> assertFailure $ "Expected success, got error: " ++ show err + Right msg -> messageRole msg @?= Assistant + , testGroup + "Precedence Rules (resolveChatRequest)" + [ testCase "inputMsgs takes priority over ChatRequest chatMessages when non-empty" $ do + p <- newOllama "base-model" defaultConfig + let invokeMsgs = [userMessage "From invoke argument"] + reqMsgs = [userMessage "From ChatRequest"] + customReq = chatRequestFor p reqMsgs + (resolvedReq, resolvedModel, resolvedMsgs) = + resolveChatRequest p invokeMsgs (Just customReq) + resolvedModel @?= "base-model" + resolvedMsgs @?= invokeMsgs + NonEmpty.toList (chatMessages resolvedReq) @?= map toOllamaMessage invokeMsgs + , testCase "fallback to ChatRequest chatMessages when inputMsgs is empty" $ do + p <- newOllama "base-model" defaultConfig + let reqMsgs = [userMessage "From ChatRequest only"] + customReq = chatRequestFor p reqMsgs + (resolvedReq, resolvedModel, resolvedMsgs) = + resolveChatRequest p [] (Just customReq) + resolvedModel @?= "base-model" + resolvedMsgs @?= reqMsgs + NonEmpty.toList (chatMessages resolvedReq) @?= map toOllamaMessage reqMsgs + , testCase "defaults to single empty message when both inputMsgs and mbReq are empty" $ do + p <- newOllama "base-model" defaultConfig + let (resolvedReq, resolvedModel, resolvedMsgs) = + resolveChatRequest p [] Nothing + resolvedModel @?= "base-model" + resolvedMsgs @?= [] + NonEmpty.toList (chatMessages resolvedReq) @?= [O.userMessage ""] + , testCase "ChatRequest chatModel overrides provider ollamaModelName when non-empty" $ do + p <- newOllama "base-model" defaultConfig + let customReq = (chatRequestFor p [userMessage "hi"]) {chatModel = ModelName "custom-model"} + (resolvedReq, resolvedModel, _) = + resolveChatRequest p [userMessage "hi"] (Just customReq) + resolvedModel @?= "custom-model" + chatModel resolvedReq @?= ModelName "custom-model" + , testCase "falls back to ollamaModelName when ChatRequest chatModel is empty" $ do + p <- newOllama "base-model" defaultConfig + let customReq = (chatRequestFor p [userMessage "hi"]) {chatModel = ModelName ""} + (resolvedReq, resolvedModel, _) = + resolveChatRequest p [userMessage "hi"] (Just customReq) + resolvedModel @?= "base-model" + chatModel resolvedReq @?= ModelName "base-model" + , testCase "falls back to ollamaModelName when mbReq is Nothing" $ do + p <- newOllama "base-model" defaultConfig + let (resolvedReq, resolvedModel, _) = + resolveChatRequest p [userMessage "hi"] Nothing + resolvedModel @?= "base-model" + chatModel resolvedReq @?= ModelName "base-model" + , testCase "preserves options, tools, format, and keep-alive from ChatRequest" $ do + p <- newOllama "base-model" defaultConfig + let opts = defaultOptions {optTemperature = Just 0.5} + customReq = + (withOptions opts (chatRequestFor p [userMessage "dummy"])) + { chatKeepAlive = Just "5m" + , chatFormat = Just OFormat.JsonFormat + } + (resolvedReq, _, _) = + resolveChatRequest p [userMessage "override message"] (Just customReq) + chatOptions resolvedReq @?= Just opts + chatKeepAlive resolvedReq @?= Just "5m" + chatFormat resolvedReq @?= Just OFormat.JsonFormat + ] + ] diff --git a/test/Test/Langchain/Provider/OllamaConversionSpec.hs b/test/Test/Langchain/Provider/OllamaConversionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Provider/OllamaConversionSpec.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Provider.OllamaConversionSpec (tests) where + +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.Strict as Map +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Core.Model +import Langchain.Provider.Ollama + ( fromOllamaMessage + , fromOllamaRole + , toOllamaMessage + , toOllamaRole + ) +import Ollama.Types.Common (Base64Image (..)) +import qualified Ollama.Types.Message as O + +tests :: TestTree +tests = + testGroup + "Langchain.Provider.OllamaConversionSpec" + [ testGroup + "Role Mapping Tests" + [ testCase "Standard roles map to Ollama equivalents" $ do + toOllamaRole System @?= O.System + toOllamaRole User @?= O.User + toOllamaRole Assistant @?= O.Assistant + toOllamaRole Tool @?= O.Tool + , testCase "Developer and Function roles map to System/Tool fallbacks" $ do + toOllamaRole Developer @?= O.System + toOllamaRole Function @?= O.Tool + , testCase "fromOllamaRole inverts toOllamaRole for core roles" $ do + fromOllamaRole O.System @?= System + fromOllamaRole O.User @?= User + fromOllamaRole O.Assistant @?= Assistant + fromOllamaRole O.Tool @?= Tool + ] + , testGroup + "Message Conversion Tests" + [ testCase "toOllamaMessage extracts base64 image data" $ do + let msg = imageMessage User "image/png" "iVBORw0KGgoAAAANSUhEUg==" + (O.Message r _ imgs _ _ _) = toOllamaMessage msg + r @?= O.User + case imgs of + Just [Base64Image b64] -> b64 @?= "iVBORw0KGgoAAAANSUhEUg==" + _ -> assertFailure "Expected single base64 image in Ollama message" + , testCase "fromOllamaMessage parses role and text content" $ do + let oMsg = O.Message O.Assistant "Response content" Nothing Nothing Nothing Nothing + msg = fromOllamaMessage oMsg + messageRole msg @?= Assistant + extractMessageText msg @?= "Response content" + , testCase "Round-trip preserves user text message" $ do + let msg = userMessage "What is pure functional programming?" + roundTripped = fromOllamaMessage (toOllamaMessage msg) + roundTripped @?= msg + , testCase "Multi-modal message with text and image converts correctly" $ do + let msg = + Message + User + ( TextBlock "Analyze this:" + NonEmpty.:| [ImageBlock $ ImageContent (ImageBase64 (Just "image/jpeg") "dGVzdA==") Nothing Nothing] + ) + Nothing + Nothing + Nothing + Map.empty + (O.Message _ txt imgs _ _ _) = toOllamaMessage msg + txt @?= "Analyze this:" + case imgs of + Just [Base64Image b64] -> b64 @?= "dGVzdA==" + _ -> assertFailure "Expected image block conversion" + ] + ] diff --git a/test/Test/Langchain/Provider/OpenAI.hs b/test/Test/Langchain/Provider/OpenAI.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Provider/OpenAI.hs @@ -0,0 +1,414 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Provider.OpenAI (tests) where + +import Control.Concurrent (newEmptyMVar, putMVar, takeMVar) +import Control.Concurrent.Async (async, poll, wait) +import Control.Concurrent.STM + ( atomically + , modifyTVar' + , newTVarIO + , readTVarIO + ) +import Control.Monad (forM, void) +import Control.Monad.Except (runExceptT) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (runResourceT) +import Data.Aeson (Value) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.ByteString.Lazy as LBS +import Data.Conduit (await, runConduit, (.|)) +import qualified Data.Conduit.Combinators as C +import Data.Maybe (fromMaybe, isJust, isNothing) +import qualified Data.Text as T +import qualified Data.Vector as V +import Network.HTTP.Types (status500) +import Network.Wai (Application, responseLBS) +import System.Environment (lookupEnv) +import System.Timeout (timeout) +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Core.Error (LangchainError) +import Langchain.Core.Model +import Langchain.Core.Stream (StreamEvent (..), TokenUsage (..), collectEvents) +import Langchain.Core.Tool (Tool, createTool, toolToValue) +import qualified Langchain.Core.Tool as CoreTool + +import Langchain.Provider.OpenAI +import Test.Langchain.Provider.TestSseServer + ( cancellationAwareSseServer + , capturingRawSseServer + , collectModelStream + , gatedSseServer + , rawSseServer + , sseFrame + , withTestApplication + ) + +withErrorProvider :: (OpenAI -> IO a) -> IO a +withErrorProvider action = + withTestApplication errorServer $ \url -> withOpenAIProvider url action + +withRawTestProvider :: [LBS.ByteString] -> (OpenAI -> IO a) -> IO a +withRawTestProvider frames action = + withTestApplication (rawSseServer frames) $ \url -> withOpenAIProvider url action + +withRequestCapturingProvider :: (Maybe Value -> IO ()) -> (OpenAI -> IO a) -> IO a +withRequestCapturingProvider captureRequest action = + withTestApplication (capturingRawSseServer (captureRequest . Aeson.decode) [sseFrame "[DONE]"]) $ \url -> + withOpenAIProvider url action + +withCancellationAwareProvider :: IO () -> (OpenAI -> IO a) -> IO a +withCancellationAwareProvider signalClientClosed action = + withTestApplication (cancellationAwareSseServer (sseFrame $ chunk "Hello") signalClientClosed) $ \url -> + withOpenAIProvider url action + +withGatedProvider :: IO () -> (OpenAI -> IO a) -> IO a +withGatedProvider waitForContinuation action = + withTestApplication + ( gatedSseServer + (sseFrame $ chunk "Hel") + waitForContinuation + [sseFrame (chunk "lo"), sseFrame "[DONE]"] + ) + $ \url -> withOpenAIProvider url action + +withOpenAIProvider :: T.Text -> (OpenAI -> IO a) -> IO a +withOpenAIProvider url action = + action $ (newOpenAI "test-key" "test-model") {baseUrl = url} + +errorServer :: Application +errorServer _request respond = respond $ responseLBS status500 [] "" + +collectRawStream :: [LBS.ByteString] -> IO (Either LangchainError [StreamEvent]) +collectRawStream frames = + withRawTestProvider frames $ \provider -> + collectModelStream provider [userMessage "Hello"] Nothing + +chunk :: LBS.ByteString -> LBS.ByteString +chunk content = + "{\"id\":\"chatcmpl-test\",\"object\":\"chat.completion.chunk\",\"created\":0,\"model\":\"test-model\",\"choices\":[{\"index\":0,\"delta\":{\"content\":\"" + <> content + <> "\"},\"finish_reason\":null}]}" + +emptyChoices :: LBS.ByteString +emptyChoices = + "{\"id\":\"chatcmpl-test\",\"object\":\"chat.completion.chunk\",\"created\":0,\"model\":\"test-model\",\"choices\":[]}" + +tests :: TestTree +tests = + testGroup + "Langchain.Provider.OpenAI" + [ testCase "newOpenAI initializes default provider" $ do + let p = newOpenAI "sk-test" "gpt-4o" + model p @?= "gpt-4o" + baseUrl p @?= "https://api.openai.com" + , testCase "openAICompatible initializes custom endpoint" $ do + let p = openAICompatible "sk-test" "custom-llm" "https://custom-ai.example.com" + model p @?= "custom-llm" + baseUrl p @?= "https://custom-ai.example.com" + , testCase "live OpenAI stream emits text and usage" $ do + mbApiKey <- lookupEnv "OPENAI_API_KEY" + case mbApiKey of + Nothing -> putStrLn " [SKIPPED] OPENAI_API_KEY is not set" + Just envApiKey -> do + envModel <- fromMaybe "gpt-4o-mini" <$> lookupEnv "OPENAI_STREAM_TEST_MODEL" + result <- + timeout 60000000 $ + runResourceT $ + runExceptT $ + collectEvents $ + stream + (newOpenAI (T.pack envApiKey) (T.pack envModel)) + [userMessage "Reply with exactly OK."] + Nothing + case result of + Nothing -> assertFailure "OpenAI stream timed out" + Just (Left err) -> assertFailure $ "Expected stream success, got: " ++ show err + Just (Right events) -> do + print events + case reverse events of + LLMEnd _ responseMessage (Just usage) : _ -> do + assertBool "Expected non-empty streamed text" $ not $ T.null $ extractMessageText responseMessage + assertBool "Expected positive total token usage" $ totalTokens usage > 0 + _ -> assertFailure $ "Expected LLMEnd with usage, got: " ++ show events + , testCase "live OpenAI stream invokes a tool and continues with its result" $ do + mbApiKey <- lookupEnv "OPENAI_API_KEY" + case mbApiKey of + Nothing -> putStrLn " [SKIPPED] OPENAI_API_KEY is not set" + Just envApiKey -> do + envModel <- fromMaybe "gpt-4o-mini" <$> lookupEnv "OPENAI_STREAM_TEST_MODEL" + let weatherTool :: Tool IO + weatherTool = + createTool + "get_weather" + "Returns the current weather for a city." + ( Aeson.object + [ "type" Aeson..= ("object" :: T.Text) + , "properties" + Aeson..= Aeson.object + [ "city" Aeson..= Aeson.object ["type" Aeson..= ("string" :: T.Text)] + ] + , "required" Aeson..= ["city" :: T.Text] + , "additionalProperties" Aeson..= False + ] + ) + (const $ pure $ Right "The weather in Paris is sunny and 22 C.") + provider = newOpenAI (T.pack envApiKey) (T.pack envModel) + runLive messages config = + timeout 60000000 $ + runResourceT $ + runExceptT $ + collectEvents $ + stream provider messages config + prompt = userMessage "Use get_weather to look up the weather in Paris, then answer using the tool result." + + firstResult <- + runLive [prompt] (Just $ openAITools [weatherTool] (OpenAIToolFunction "get_weather")) + firstEvents <- case firstResult of + Nothing -> assertFailure "OpenAI tool-call stream timed out" >> fail "unreachable" + Just (Left err) -> assertFailure ("Expected tool-call stream success, got: " ++ show err) >> fail "unreachable" + Just (Right events) -> pure events + (assistant, toolCalls) <- case reverse firstEvents of + LLMEnd _ responseMessage _ : _ -> case messageToolCalls responseMessage of + Just calls@[toolCall] + | toolCallName toolCall == "get_weather" -> pure (responseMessage, calls) + _ -> assertFailure ("Expected OpenAI tool call, got: " ++ show firstEvents) >> fail "unreachable" + _ -> assertFailure ("Expected tool-call stream end, got: " ++ show firstEvents) >> fail "unreachable" + toolResults <- forM toolCalls $ \toolCall -> do + output <- CoreTool.toolExecute weatherTool (toolCallArguments toolCall) + case output of + Left err -> assertFailure ("Tool execution failed: " ++ show err) >> fail "unreachable" + Right text -> + pure $ + (textMessage Tool text) + { messageName = Just (toolCallName toolCall) + , messageToolId = Just (toolCallId toolCall) + } + secondResult <- runLive ([prompt, assistant] <> toolResults) Nothing + case secondResult of + Nothing -> assertFailure "OpenAI tool-result stream timed out" + Just (Left err) -> assertFailure $ "Expected tool-result stream success, got: " ++ show err + Just (Right events) -> case reverse events of + LLMEnd _ responseMessage (Just usage) : _ -> do + assertBool "Expected final text after tool result" $ + not $ + T.null $ + extractMessageText responseMessage + assertBool "Expected positive total token usage" $ totalTokens usage > 0 + _ -> assertFailure $ "Expected LLMEnd with usage, got: " ++ show events + , testCase "normalizeBaseUrl strips endpoint paths for servant compatibility" $ do + normalizeBaseUrl "https://api.openai.com" @?= "https://api.openai.com" + normalizeBaseUrl "https://api.openai.com/" @?= "https://api.openai.com" + normalizeBaseUrl "https://api.openai.com/v1" @?= "https://api.openai.com" + normalizeBaseUrl "https://api.openai.com/v1/" @?= "https://api.openai.com" + normalizeBaseUrl "https://api.openai.com/v1/chat/completions" @?= "https://api.openai.com" + normalizeBaseUrl "https://openrouter.ai/api" @?= "https://openrouter.ai/api" + normalizeBaseUrl "https://openrouter.ai/api/v1" @?= "https://openrouter.ai/api" + normalizeBaseUrl "https://openrouter.ai/api/v1/chat/completions" @?= "https://openrouter.ai/api" + normalizeBaseUrl "http://localhost:11434/v1" @?= "http://localhost:11434" + , testCase "stream emits chunks and ends at [DONE]" $ do + result <- collectRawStream [sseFrame $ chunk "Hel", sseFrame $ chunk "lo", sseFrame "[DONE]"] + case result of + Left err -> assertFailure $ "Expected stream success, got: " ++ show err + Right events -> case events of + [ LLMStart {} + , LLMChunk _ "Hel" Nothing + , LLMChunk _ "lo" Nothing + , LLMEnd _ responseMessage Nothing + ] -> extractMessageText responseMessage @?= "Hello" + _ -> assertFailure $ "Unexpected stream events: " ++ show events + , testCase "stream delivers a chunk before the response completes" $ do + firstChunkReceived <- newEmptyMVar + continueResponse <- newEmptyMVar + receivedEvents <- newTVarIO [] + withGatedProvider (takeMVar continueResponse) $ \provider -> do + consumer <- + async + . runResourceT + . runExceptT + . runConduit + $ stream provider [userMessage "Hello"] Nothing + .| C.mapM_ + ( \event -> do + liftIO . atomically $ modifyTVar' receivedEvents (event :) + case event of + LLMChunk _ "Hel" _ -> liftIO $ putMVar firstChunkReceived () + _ -> pure () + ) + received <- timeout 500000 $ takeMVar firstChunkReceived + assertBool "expected first chunk before releasing the response" $ isJust received + stillStreaming <- poll consumer + assertBool "consumer should wait for the remaining response" $ isNothing stillStreaming + putMVar continueResponse () + result <- timeout 500000 $ wait consumer + case result of + Nothing -> assertFailure "stream did not finish after releasing the response" + Just (Left err) -> assertFailure $ "Expected stream success, got: " ++ show err + Just (Right ()) -> do + events <- reverse <$> readTVarIO receivedEvents + case reverse events of + LLMEnd _ responseMessage Nothing : _ -> + extractMessageText responseMessage @?= "Hello" + _ -> assertFailure $ "Expected a completed stream, got: " ++ show events + , testCase "stream finishes when the SSE connection closes" $ do + result <- collectRawStream [sseFrame $ chunk "Hello"] + case result of + Left err -> assertFailure $ "Expected stream success, got: " ++ show err + Right events -> case events of + [LLMStart {}, LLMChunk _ "Hello" Nothing, LLMEnd _ responseMessage Nothing] -> + extractMessageText responseMessage @?= "Hello" + _ -> assertFailure $ "Unexpected stream events: " ++ show events + , testCase "stream ignores chunks without choices" $ do + result <- collectRawStream [sseFrame emptyChoices, sseFrame "[DONE]"] + case result of + Left err -> assertFailure $ "Expected stream success, got: " ++ show err + Right events -> case events of + [LLMStart {}, LLMEnd _ responseMessage Nothing] -> + extractMessageText responseMessage @?= "" + _ -> assertFailure $ "Unexpected stream events: " ++ show events + , testCase "stream converts malformed SSE data to LangchainError" $ do + result <- collectRawStream [sseFrame "not JSON"] + case result of + Left _ -> pure () + Right events -> assertFailure $ "Expected stream failure, got: " ++ show events + , testCase "stream converts HTTP errors to LangchainError" $ do + result <- withErrorProvider $ \provider -> + runResourceT $ runExceptT $ collectEvents (stream provider [userMessage "Hello"] Nothing) + case result of + Left _ -> pure () + Right events -> assertFailure $ "Expected stream failure, got: " ++ show events + , testCase "stream handles SSE frames written in multiple pieces" $ do + let frame = sseFrame $ chunk "Hello" + splitPoint = LBS.length frame `div` 2 + fragments = [LBS.take splitPoint frame, LBS.drop splitPoint frame, "data: [DONE]\n\n"] + result <- collectRawStream fragments + case result of + Left err -> assertFailure $ "Expected stream success, got: " ++ show err + Right events -> case events of + [LLMStart {}, LLMChunk _ "Hello" Nothing, LLMEnd _ responseMessage Nothing] -> + extractMessageText responseMessage @?= "Hello" + _ -> assertFailure $ "Unexpected stream events: " ++ show events + , testCase "stream requests usage in stream options" $ do + requestBody <- newEmptyMVar + withRequestCapturingProvider (putMVar requestBody) $ \provider -> do + void . runResourceT . runExceptT $ collectEvents (stream provider [userMessage "Hello"] Nothing) + mbRequest <- takeMVar requestBody + case mbRequest of + Nothing -> assertFailure "Expected JSON request body" + Just (Aeson.Object fields) -> do + KeyMap.lookup "stream" fields @?= Just (Aeson.Bool True) + KeyMap.lookup "stream_options" fields @?= Just (Aeson.object ["include_usage" Aeson..= True]) + Just request -> assertFailure $ "Expected JSON object, got: " ++ show request + , testCase "stream sends tool definitions and tool choice" $ do + let weatherTool :: Tool IO + weatherTool = createTool "get_weather" "Gets the weather" (Aeson.object []) (const $ pure $ Right "sunny") + config = openAITools [weatherTool] (OpenAIToolFunction "get_weather") + requestBody <- newEmptyMVar + withRequestCapturingProvider (putMVar requestBody) $ \provider -> do + void . runResourceT . runExceptT $ + collectEvents (stream provider [userMessage "Hello"] (Just config)) + mbRequest <- takeMVar requestBody + case mbRequest of + Just (Aeson.Object fields) -> do + KeyMap.lookup "tools" fields @?= Just (Aeson.toJSON [toolToValue weatherTool]) + KeyMap.lookup "tool_choice" fields + @?= Just + ( Aeson.object + [ "type" Aeson..= ("function" :: T.Text) + , "function" Aeson..= Aeson.object ["name" Aeson..= ("get_weather" :: T.Text)] + ] + ) + Just request -> assertFailure $ "Expected JSON object, got: " ++ show request + Nothing -> assertFailure "Expected JSON request body" + , testCase "stream sends assistant tool calls before tool results" $ do + let toolCall = + ToolCall + "call_weather" + "function" + "get_weather" + (Aeson.object ["city" Aeson..= ("Paris" :: T.Text)]) + assistant = (assistantMessage "") {messageToolCalls = Just [toolCall]} + toolResult = (textMessage Tool "Sunny") {messageToolId = Just "call_weather"} + requestBody <- newEmptyMVar + withRequestCapturingProvider (putMVar requestBody) $ \provider -> do + void . runResourceT . runExceptT $ + collectEvents (stream provider [userMessage "Weather?", assistant, toolResult] Nothing) + mbRequest <- takeMVar requestBody + case mbRequest of + Just (Aeson.Object fields) -> case KeyMap.lookup "messages" fields of + Just (Aeson.Array messages) -> case V.toList messages of + [_, Aeson.Object assistantFields, Aeson.Object toolResultFields] -> do + KeyMap.lookup "tool_calls" assistantFields + @?= Just + ( Aeson.toJSON + [ Aeson.object + [ "id" Aeson..= ("call_weather" :: T.Text) + , "type" Aeson..= ("function" :: T.Text) + , "function" + Aeson..= Aeson.object + [ "name" Aeson..= ("get_weather" :: T.Text) + , "arguments" Aeson..= ("{\"city\":\"Paris\"}" :: T.Text) + ] + ] + ] + ) + KeyMap.lookup "tool_call_id" toolResultFields @?= Just (Aeson.String "call_weather") + messages' -> assertFailure $ "Expected three request messages, got: " ++ show messages' + request -> assertFailure $ "Expected messages array, got: " ++ show request + Just request -> assertFailure $ "Expected JSON object, got: " ++ show request + Nothing -> assertFailure "Expected JSON request body" + , testCase "stream accumulates text, fragmented tool calls, and usage" $ do + let frames = + [ sseFrame + "{\"id\":\"chatcmpl-test\",\"object\":\"chat.completion.chunk\",\"created\":0,\"model\":\"test-model\",\"choices\":[{\"index\":0,\"delta\":{\"content\":\"Checking weather...\"},\"finish_reason\":null}]}" + , sseFrame + "{\"id\":\"chatcmpl-test\",\"object\":\"chat.completion.chunk\",\"created\":0,\"model\":\"test-model\",\"choices\":[{\"index\":0,\"delta\":{\"tool_calls\":[{\"index\":0,\"id\":\"call_1\",\"type\":\"function\",\"function\":{\"name\":\"get_weather\",\"arguments\":\"{\\\"city\\\":\\\"\"}}]},\"finish_reason\":null}]}" + , sseFrame + "{\"id\":\"chatcmpl-test\",\"object\":\"chat.completion.chunk\",\"created\":0,\"model\":\"test-model\",\"choices\":[{\"index\":0,\"delta\":{\"tool_calls\":[{\"index\":0,\"function\":{\"arguments\":\"Paris\\\"}\"}}]},\"finish_reason\":\"tool_calls\"}]}" + , sseFrame + "{\"id\":\"chatcmpl-test\",\"object\":\"chat.completion.chunk\",\"created\":0,\"model\":\"test-model\",\"choices\":[],\"usage\":{\"prompt_tokens\":7,\"completion_tokens\":5,\"total_tokens\":12}}" + , sseFrame "[DONE]" + ] + expectedToolCall = + ToolCall + { toolCallId = "call_1" + , toolCallType = "function" + , toolCallName = "get_weather" + , toolCallArguments = Aeson.object ["city" Aeson..= ("Paris" :: T.Text)] + } + expectedUsage = TokenUsage 7 5 12 + result <- collectRawStream frames + case result of + Left err -> assertFailure $ "Expected stream success, got: " ++ show err + Right events -> case events of + [ LLMStart {} + , LLMChunk _ "Checking weather..." Nothing + , LLMChunk _ "" (Just toolCall) + , LLMEnd _ responseMessage (Just usage) + ] -> do + toolCall @?= expectedToolCall + extractMessageText responseMessage @?= "Checking weather..." + messageToolCalls responseMessage @?= Just [expectedToolCall] + usage @?= expectedUsage + _ -> assertFailure $ "Unexpected stream events: " ++ show events + , testCase "stream rejects invalid completed tool arguments" $ do + let frames = + [ sseFrame + "{\"id\":\"chatcmpl-test\",\"object\":\"chat.completion.chunk\",\"created\":0,\"model\":\"test-model\",\"choices\":[{\"index\":0,\"delta\":{\"tool_calls\":[{\"index\":0,\"id\":\"call_1\",\"type\":\"function\",\"function\":{\"name\":\"get_weather\",\"arguments\":\"not-json\"}}]},\"finish_reason\":\"tool_calls\"}]}" + , sseFrame "[DONE]" + ] + result <- collectRawStream frames + case result of + Left _ -> pure () + Right events -> assertFailure $ "Expected stream failure, got: " ++ show events + , testCase "stream closes the SSE connection when the consumer stops after a chunk" $ do + clientClosed <- newEmptyMVar + withCancellationAwareProvider (putMVar clientClosed ()) $ \provider -> do + void . runResourceT . runExceptT . runConduit $ + stream provider [userMessage "Hello"] Nothing .| (await >> await) + closed <- timeout 500000 $ takeMVar clientClosed + assertBool "expected the SSE connection to close" $ isJust closed + ] diff --git a/test/Test/Langchain/Provider/TestSseServer.hs b/test/Test/Langchain/Provider/TestSseServer.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Provider/TestSseServer.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Langchain.Provider.TestSseServer + ( withTestApplication + , rawSseServer + , capturingRawSseServer + , capturingRawSseRequestServer + , sseFrame + , gatedSseServer + , cancellationAwareSseServer + , collectModelStream + ) where + +import Control.Concurrent (threadDelay) +import Control.Exception (SomeException, catch) +import Control.Monad.Except (runExceptT) +import Control.Monad.Trans.Resource (runResourceT) +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as T +import Network.HTTP.Types (hContentType, status200) +import Network.Wai (Application, Request, responseStream, strictRequestBody) +import Network.Wai.Handler.Warp (testWithApplication) + +import Langchain.Core.Error (LangchainError) +import Langchain.Core.Model (ChatModel (..), Message) +import Langchain.Core.Stream (StreamEvent, collectEvents) + +withTestApplication :: Application -> (T.Text -> IO a) -> IO a +withTestApplication app action = + testWithApplication (pure app) $ \port -> + action $ "http://127.0.0.1:" <> T.pack (show port) + +rawSseServer :: [LBS.ByteString] -> Application +rawSseServer frames _request respond = + respond $ + responseStream status200 [(hContentType, "text/event-stream")] $ \write flush -> + mapM_ (\frame -> write (Builder.lazyByteString frame) >> flush) frames + +capturingRawSseServer :: (LBS.ByteString -> IO ()) -> [LBS.ByteString] -> Application +capturingRawSseServer captureRequest frames request respond = do + captureRequest =<< strictRequestBody request + rawSseServer frames request respond + +capturingRawSseRequestServer :: + (Request -> LBS.ByteString -> IO ()) -> [LBS.ByteString] -> Application +capturingRawSseRequestServer captureRequest frames request respond = do + body <- strictRequestBody request + captureRequest request body + rawSseServer frames request respond + +sseFrame :: LBS.ByteString -> LBS.ByteString +sseFrame payload = "data: " <> payload <> "\n\n" + +gatedSseServer :: LBS.ByteString -> IO () -> [LBS.ByteString] -> Application +gatedSseServer firstFrame waitForContinuation remainingFrames _request respond = + respond $ + responseStream status200 [(hContentType, "text/event-stream")] $ \write flush -> do + write $ Builder.lazyByteString firstFrame + flush + waitForContinuation + mapM_ (write . Builder.lazyByteString) remainingFrames + flush + +cancellationAwareSseServer :: LBS.ByteString -> IO () -> Application +cancellationAwareSseServer firstFrame signalClientClosed _request respond = + respond $ + responseStream status200 [(hContentType, "text/event-stream")] $ \write flush -> do + let keepAlive = do + write ": keepalive\n\n" + flush + threadDelay 1000 + keepAlive + onDisconnect :: SomeException -> IO () + onDisconnect _ = signalClientClosed + write $ Builder.lazyByteString firstFrame + flush + keepAlive `catch` onDisconnect + +collectModelStream :: + ChatModel model => + model -> [Message] -> Maybe (ModelConfig model) -> IO (Either LangchainError [StreamEvent]) +collectModelStream provider messages config = + runResourceT $ runExceptT $ collectEvents (stream provider messages config) diff --git a/test/Test/Langchain/RegressionSpec.hs b/test/Test/Langchain/RegressionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/RegressionSpec.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.RegressionSpec (tests) where + +import Control.Monad.Except (runExceptT) +import Control.Monad.Trans.Resource (runResourceT) +import Data.Aeson (decode) +import qualified Data.ByteString.Lazy.Char8 as LBSC +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Agent.ReAct +import Langchain.Core.Model +import Langchain.Core.Stream +import Langchain.Memory.Core (BaseMemory (..), newWindowBufferMemory) +import qualified Langchain.Memory.Core as TB +import Langchain.Provider.OpenAI (parseOpenAIResponse) +import Langchain.Tool.Calculator (calculatorTool) +import Test.Langchain.Provider.Mock (newMockModel) + +tests :: TestTree +tests = + testGroup + "Langchain.RegressionSpec" + [ testCase "regression_ollama_stream_lifecycle: StreamEvent stream ends with LLMEnd" $ do + let mockModel = newMockModel "Streaming chunk data" + input = [userMessage "Ping"] + res <- runResourceT $ runExceptT $ collectEvents (stream mockModel input Nothing) + case res of + Left err -> assertFailure ("Stream failed: " ++ show err) + Right events -> do + length events @?= 3 + case last events of + LLMEnd _ finalMsg _ -> extractMessageText finalMsg @?= "Streaming chunk data" + _ -> assertFailure "Expected LLMEnd as last event in stream" + , testCase "regression_system_fingerprint_nullable: OpenAI JSON parses without fingerprint" $ do + let jsonWithoutFingerprint = + "{\"id\":\"cmpl-1\",\"object\":\"chat.completion\",\"created\":1600000000,\"model\":\"gpt-4o\",\"choices\":[{\"index\":0,\"message\":{\"role\":\"assistant\",\"content\":\"OK\"},\"finish_reason\":\"stop\"}],\"usage\":{\"prompt_tokens\":1,\"completion_tokens\":1,\"total_tokens\":2}}" + case decode (LBSC.pack jsonWithoutFingerprint) of + Nothing -> assertFailure "Failed to decode JSON value" + Just val -> case parseOpenAIResponse val of + Left err -> assertFailure ("OpenAI parsing failed on nullable fingerprint: " ++ err) + Right (msg, _) -> extractMessageText msg @?= "OK" + , testCase "regression_react_agent_plain_response: Completes immediately when no tool calls" $ do + let mockModel = newMockModel "Direct Answer without tool calls" + agent = createReActAgent mockModel [calculatorTool] + res <- runExceptT $ runReActAgent agent [userMessage "What is the capital of France?"] + case res of + Left err -> assertFailure ("ReAct agent failed: " ++ show err) + Right finalMsg -> extractMessageText finalMsg @?= "Direct Answer without tool calls" + , testCase "regression_memory_window_trimming: System message preserved during trimming" $ do + let sys = systemMessage "System Prompt" + u1 = userMessage "User 1" + u2 = userMessage "User 2" + mem <- newWindowBufferMemory 2 [sys, u1] + res <- runExceptT $ do + addMessage mem u2 + messages mem + case res of + Left err -> assertFailure ("Memory failed: " ++ show err) + Right msgs -> msgs @?= [sys, u2] + , testCase "regression_token_buffer_system_preservation: System message kept within token budget" $ do + let sys = systemMessage "Sys" + u1 = userMessage "Long user message 12345678" + u2 = userMessage "Long user message 12345678" + mem <- TB.newTokenBufferMemory 8 [sys, u1] + res <- runExceptT $ do + addMessage mem u2 + messages mem + case res of + Left err -> assertFailure ("TokenBuffer failed: " ++ show err) + Right msgs -> do + assertBool "Contains system message" (any (\m -> messageRole m == System) msgs) + ] diff --git a/test/Test/Langchain/Resilience/CircuitBreakerSpec.hs b/test/Test/Langchain/Resilience/CircuitBreakerSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Resilience/CircuitBreakerSpec.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Resilience.CircuitBreakerSpec (tests) where + +import Control.Monad.Except (runExceptT, throwError) +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Core.Error (internalError) +import Langchain.Resilience.CircuitBreaker + +tests :: TestTree +tests = + testGroup + "Langchain.Resilience.CircuitBreakerSpec" + [ testCase "CircuitBreaker starts in Closed state and passes successful requests" $ do + cb <- newCircuitBreaker "test-cb" defaultCircuitConfig + st <- getCircuitState cb + st @?= CircuitClosed + res <- runExceptT $ withCircuitBreaker cb (pure ("ok" :: String)) + res @?= Right "ok" + , testCase "CircuitBreaker transitions to Open after exceeding failure threshold" $ do + let cfg = CircuitBreakerConfig {failureThreshold = 2, resetTimeoutSec = 0.1} + cb <- newCircuitBreaker "failing-cb" cfg + -- First failure + _ <- runExceptT $ withCircuitBreaker cb (throwError (internalError "fail 1" Nothing Nothing)) + st1 <- getCircuitState cb + st1 @?= CircuitClosed + -- Second failure -> should open + _ <- runExceptT $ withCircuitBreaker cb (throwError (internalError "fail 2" Nothing Nothing)) + st2 <- getCircuitState cb + case st2 of + CircuitOpen _ -> pure () + _ -> assertFailure "Expected CircuitOpen state" + -- Third request fast-fails without executing action + resFastFail <- runExceptT $ withCircuitBreaker cb (pure ("should not execute" :: String)) + case resFastFail of + Left _ -> pure () + Right _ -> assertFailure "Expected circuit breaker fast-fail error" + ] diff --git a/test/Test/Langchain/Resilience/RetrySpec.hs b/test/Test/Langchain/Resilience/RetrySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Resilience/RetrySpec.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Resilience.RetrySpec (tests) where + +import Control.Concurrent.STM +import Control.Monad.Except (runExceptT, throwError) +import Control.Monad.IO.Class (liftIO) +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Core.Error (internalError) +import Langchain.Resilience.Retry + +tests :: TestTree +tests = + testGroup + "Langchain.Resilience.RetrySpec" + [ testCase "withRetry succeeds after failing attempts" $ do + attemptVar <- newTVarIO (0 :: Int) + let policy = defaultRetryPolicy {maxRetries = 3, baseDelayMicros = 1000, useJitter = False} + action = do + curr <- liftIO $ atomically $ do + c <- readTVar attemptVar + writeTVar attemptVar (c + 1) + pure c + if curr < 2 + then throwError $ internalError "Temporary failure" Nothing Nothing + else pure ("Success on attempt " ++ show (curr + 1)) + res <- runExceptT $ withRetry policy action + res @?= Right "Success on attempt 3" + , testCase "RateLimiter consumes tokens and executes action" $ do + limiter <- newRateLimiter 5.0 5.0 + res <- withRateLimit limiter (pure (42 :: Int)) + res @?= 42 + ] diff --git a/test/Test/Langchain/Retriever/BM25Spec.hs b/test/Test/Langchain/Retriever/BM25Spec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Retriever/BM25Spec.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Retriever.BM25Spec (tests) where + +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +import Langchain.DocumentLoader.Core (Document (..)) +import Langchain.Retriever.BM25 + +tests :: TestTree +tests = + testGroup + "Langchain.Retriever.BM25" + [ testCase "BM25 finds exact matching document" $ do + let doc1 = + Document + { pageContent = "Haskell is a functional programming language with strong static types." + , metadata = Map.empty + } + doc2 = + Document + { pageContent = "Python is a dynamic language used for machine learning and web scripts." + , metadata = Map.empty + } + doc3 = + Document + { pageContent = "Rust guarantees memory safety without garbage collection." + , metadata = Map.empty + } + index = newBM25Index [doc1, doc2, doc3] + results = bm25Search index "functional static types" 2 + case results of + (topResult : _) -> topResult @?= doc1 + [] -> assertFailure "Expected non-empty search results" + , testCase "BM25 scoring gives highest score to relevant passage" $ do + let doc1 = + Document + { pageContent = "Deep research agent explores web pages and validates claims." + , metadata = Map.empty + } + doc2 = + Document + { pageContent = "Database query optimization and index scans in postgresql." + , metadata = Map.empty + } + index = newBM25Index [doc1, doc2] + scored = bm25SearchWithScores index "deep research agent" 2 + case scored of + [(bestDoc, score)] -> do + bestDoc @?= doc1 + assertBool "Score should be positive" (score > 0.0) + _ -> assertFailure ("Expected 1 scored result, got " ++ show (length scored)) + , testCase "addDocumentsBM25 updates index correctly" $ do + let doc1 = Document {pageContent = "Alpha beta gamma", metadata = Map.empty} + doc2 = Document {pageContent = "Delta epsilon zeta", metadata = Map.empty} + index1 = newBM25Index [doc1] + index2 = addDocumentsBM25 [doc2] index1 + results = bm25Search index2 "epsilon" 5 + results @?= [doc2] + , testProperty "Tokenize lowercases and strips punctuation" $ + \s -> + let txt = T.pack s + tokens = tokenize txt + in all (\t -> T.toLower t == t) tokens + ] diff --git a/test/Test/Langchain/Retriever/Core.hs b/test/Test/Langchain/Retriever/Core.hs --- a/test/Test/Langchain/Retriever/Core.hs +++ b/test/Test/Langchain/Retriever/Core.hs @@ -1,88 +1,30 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} module Test.Langchain.Retriever.Core (tests) where +import Control.Monad.Except (runExceptT) +import qualified Data.Map.Strict as HM +import qualified Data.Text.Lazy as TL import Test.Tasty import Test.Tasty.HUnit -import qualified Data.Text.Lazy as T import Langchain.DocumentLoader.Core (Document (..)) -import Langchain.LLM.Core (LLM (..)) -import qualified Langchain.LLM.Core as LLM import Langchain.Retriever.Core (Retriever (..)) -import Langchain.Retriever.MultiQueryRetriever -import qualified Data.Map.Strict as HM -import Data.Text (Text) - -data DummyLLM = DummyLLM - --- TODO: Add some real world examples here -instance LLM DummyLLM where - type LLMParams DummyLLM = String - type LLMStreamTokenType DummyLLM = Text - - -- When 'generate' is called, we return a fixed response in the format expected by the - -- NumberSeparatedList parser. For example: - -- - -- "1. test query 1\n2. test query 2" - generate _ _ _ = return $ Right "1. test query 1\n2. test query 2" - chat _ _ _ = return $ Right $ LLM.Message LLM.User "dummy chat response" LLM.defaultMessageData - stream _ _ _ _ = return $ Right () - data DummyRetriever = DummyRetriever + deriving (Show, Eq) instance Retriever DummyRetriever where - _get_relevant_documents _ query = - return $ Right [Document (T.fromStrict $ query <> " result") HM.empty] - -test_generateQueries :: Assertion -test_generateQueries = do - let dummyLLM = DummyLLM - query = "original query" - numQueriesToGenerate = 2 - includeOriginal = True - queryPrompt = defaultQueryGenerationPrompt - result <- generateQueries dummyLLM queryPrompt query numQueriesToGenerate includeOriginal - case result of - Left err -> assertFailure ("generateQueries failed with error: " ++ show err) - Right qs -> do - let expectedQueries = - [ "original query" - , "test query 1" - , "test query 2" - ] - length qs @?= 3 - qs @?= expectedQueries - --- Test the MultiQueryRetriever _get_relevant_documents implementation. -test_MultiQueryRetriever :: Assertion -test_MultiQueryRetriever = do - let dummyLLM = DummyLLM - dummyRetriever = DummyRetriever - -- Create a MultiQueryRetriever using the dummy implementations. - mqRetriever = newMultiQueryRetriever dummyRetriever dummyLLM - originalQuery = "original query" - result <- _get_relevant_documents mqRetriever originalQuery - case result of - Left err -> assertFailure ("MultiQueryRetriever failed with error: " ++ show err) - Right docs -> do - -- Since generateQueries returns three queries (original plus two generated), - -- and DummyRetriever returns one document per query, we expect 3 documents. - length docs @?= 3 - let contents = map pageContent docs - expectedContents = - [ "original query result" - , "test query 1 result" - , "test query 2 result" - ] - contents @?= expectedContents + getRelevantDocuments _ query = + pure [Document (TL.fromStrict $ query <> " result") HM.empty] tests :: TestTree tests = testGroup "Retriever Tests" - [ testCase "generateQueries returns expected queries" test_generateQueries - , testCase "MultiQueryRetriever retrieves and combines documents" test_MultiQueryRetriever + [ testCase "DummyRetriever retrieves documents" $ do + res <- runExceptT $ getRelevantDocuments DummyRetriever "test" + case res of + Left err -> assertFailure ("Error: " ++ show err) + Right docs -> map pageContent docs @?= ["test result"] ] diff --git a/test/Test/Langchain/Retriever/HybridSpec.hs b/test/Test/Langchain/Retriever/HybridSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Retriever/HybridSpec.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Retriever.HybridSpec (tests) where + +import qualified Data.Map.Strict as Map +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.DocumentLoader.Core (Document (..)) +import Langchain.Retriever.BM25 (newBM25Index) +import Langchain.Retriever.Hybrid + +tests :: TestTree +tests = + testGroup + "Langchain.Retriever.Hybrid" + [ testCase "reciprocalRankFusion prioritizes documents appearing in both lists" $ do + let docA = Document {pageContent = "Document A about quantum algorithms", metadata = Map.empty} + docB = Document {pageContent = "Document B about classical physics", metadata = Map.empty} + docC = Document {pageContent = "Document C about neural networks", metadata = Map.empty} + denseList = [docA, docB] + sparseList = [docC, docA] + fused = reciprocalRankFusion 60.0 [(denseList, 1.0), (sparseList, 1.0)] + -- docA appears in both dense (rank 1) and sparse (rank 2) -> highest combined score + length fused @?= 3 + case fused of + ((topDoc, _) : _) -> topDoc @?= docA + [] -> assertFailure "Expected non-empty fused results" + , testCase "searchHybrid executes dense and sparse searches" $ do + let doc1 = Document {pageContent = "Haskell state monad and effects", metadata = Map.empty} + doc2 = Document {pageContent = "Rust borrow checker and lifetimes", metadata = Map.empty} + bm25 = newBM25Index [doc1, doc2] + mockVecSearch _ _ = pure [doc2, doc1] + hybrid = newHybridRetriever bm25 mockVecSearch + results <- searchHybrid hybrid "Haskell" 2 + length results @?= 2 + case results of + (topDoc : _) -> topDoc @?= doc1 + [] -> assertFailure "Expected non-empty results" + ] diff --git a/test/Test/Langchain/Runnable/Chains.hs b/test/Test/Langchain/Runnable/Chains.hs deleted file mode 100644 --- a/test/Test/Langchain/Runnable/Chains.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - -module Test.Langchain.Runnable.Chains (tests) where - -import Langchain.Error (LangchainError, llmError) -import Langchain.Runnable.Chain -import Langchain.Runnable.Core -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertEqual, testCase) - -addOne :: MockRunnable Int Int -addOne = MockRunnable (\x -> return $ Right (x + 1)) - -multiplyByTwo :: MockRunnable Int Int -multiplyByTwo = MockRunnable (\x -> return $ Right (x * 2)) - -evenCheck :: MockRunnable Int Bool -evenCheck = MockRunnable $ return . Right . even - -failingMock :: MockRunnable a b -failingMock = MockRunnable (\_ -> return $ Left (llmError "Mock error" Nothing Nothing)) - -newtype MockRunnable a b = MockRunnable {runMock :: a -> IO (Either LangchainError b)} - -instance Runnable (MockRunnable a b) where - type RunnableInput (MockRunnable a b) = a - type RunnableOutput (MockRunnable a b) = b - invoke = runMock - -tests :: TestTree -tests = - testGroup - "Runnable Chain Tests" - [ testGroup - "RunnableBranch Tests" - [ testCase "Selects first matching branch" $ do - let branch1 = - RunnableBranch - [ ((== 1), addOne) - , ((== 2), multiplyByTwo) - ] - failingMock - result <- runBranch branch1 1 - assertEqual "Should choose addOne branch" (Right 2) result - , testCase "Uses default when no conditions match" $ do - let defaultBranch = RunnableBranch [] addOne - result <- runBranch defaultBranch 5 - assertEqual "Should use default" (Right 6) result - ] - , testGroup - "RunnableMap Tests" - [ testCase "Applies input/output transformations" $ do - let inputMap = (* 2) - outputMap = (+ 1) - mapped = RunnableMap inputMap outputMap addOne - result <- runMap mapped 3 -- 3*2=6 → addOne →7 → +1 →8 - assertEqual "Transformations applied" (Right 8) result - ] - , testGroup - "RunnableSequence Tests" - [ testCase "Executes sequence in order" $ do - let sequence0 = buildSequence addOne multiplyByTwo - result <- runSequence sequence0 2 -- 2+1=3 → *2=6 - assertEqual "Sequence executed" (Right 6) result - - {- - , testCase "Handles multi-step sequences" $ do - let sequence_ = (addOne |>> multiplyByTwo) |>> evenCheck - result <- sequence_ 3 -- 3+1=4 → *2=8 → even → True - assertEqual "Three-step sequence" (Right True) result - -} - ] - , testGroup - "Chain Operator Tests" - [ testCase "Chains two runnables" $ do - let pipeline = addOne |>> multiplyByTwo - result <- pipeline 3 - assertEqual "3+1=4 → *2=8" (Right 8) result - , testCase "Propagates errors in chain" $ do - let pipeline = failingMock |>> multiplyByTwo - result <- pipeline () - assertEqual "Error in first step" (Left (llmError "Mock error" Nothing Nothing)) result - ] - , testGroup - "Branch Tests" - [ testCase "Runs parallel branches" $ do - result <- branch evenCheck addOne 4 - assertEqual "Both branches run" (Right (True, 5)) result - , testCase "Handles branch errors" $ do - result <- branch failingMock addOne 5 - assertEqual - "Left error in first branch" - (Left (llmError "Mock error" Nothing Nothing) :: Either LangchainError (Bool, Int)) - result - ] - ] diff --git a/test/Test/Langchain/Runnable/ConversationChains.hs b/test/Test/Langchain/Runnable/ConversationChains.hs deleted file mode 100644 --- a/test/Test/Langchain/Runnable/ConversationChains.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - -module Test.Langchain.Runnable.ConversationChains (tests) where - -import Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef) -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NE -import Data.Text (Text) -import Langchain.Error (LangchainError, llmError, memoryError) -import Langchain.LLM.Core -import Langchain.Memory.Core (BaseMemory (..)) -import Langchain.PromptTemplate (PromptTemplate (..)) -import Langchain.Runnable.ConversationChain -import Langchain.Runnable.Core -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertEqual, testCase, (@?=)) - -newtype TestMemory = TestMemory (IORef [Message]) - -instance BaseMemory TestMemory where - addUserMessage (TestMemory ref) input = do - let userMsg = Message User input defaultMessageData - modifyIORef ref (++ [userMsg]) - return $ Right (TestMemory ref) - - addAiMessage (TestMemory ref) response = do - let aiMsg = Message Assistant response defaultMessageData - modifyIORef ref (++ [aiMsg]) - return $ Right (TestMemory ref) - - addMessage (TestMemory ref) msg = do - modifyIORef ref (++ [msg]) - return $ Right (TestMemory ref) - - clear (TestMemory ref) = do - writeIORef ref [] - return $ Right $ TestMemory ref - - messages (TestMemory ref) = fmap Right (NE.fromList <$> readIORef ref) - -data FailingMemory = FailingMemory - -instance BaseMemory FailingMemory where - addUserMessage _ _ = return $ Left $ memoryError "Memory error" Nothing Nothing - addAiMessage _ _ = return $ Left $ memoryError "Memory error" Nothing Nothing - messages _ = return $ Left $ memoryError "Memory error" Nothing Nothing - addMessage _ _ = return $ Left $ memoryError "Memory error" Nothing Nothing - clear _ = return $ Left $ memoryError "Memory error" Nothing Nothing - -data MockLLM = MockLLM - { llmResponse :: Either LangchainError Message - , receivedMessages :: IORef [Message] - } - -instance LLM MockLLM where - type LLMParams MockLLM = String - type LLMStreamTokenType MockLLM = Text - - chat llm0 (msgs :: NonEmpty Message) _ = do - writeIORef (receivedMessages llm0) (NE.toList msgs) - return (llmResponse llm0) - generate = undefined - stream = undefined - -tests :: TestTree -tests = - testGroup - "ConversationChain Tests" - [ testCase "Basic conversation flow" $ do - memRef <- newIORef [] - let testMem = TestMemory memRef - msgRef <- newIORef [] - let mockLLM = MockLLM (Right $ Message User "Hello!" defaultMessageData) msgRef - chain = ConversationChain testMem mockLLM (PromptTemplate "") - result <- invoke chain "Hi" - result @?= Right "Hello!" - -- Verify LLM received correct messages - received <- readIORef msgRef - assertEqual "LLM received user message" [Message User "Hi" defaultMessageData] received - -- Verify memory contains both messages - mem <- readIORef memRef - assertEqual - "Memory has user and AI messages" - [ Message User "Hi" defaultMessageData - , Message Assistant "Hello!" defaultMessageData - ] - mem - , testCase "Error adding user message" $ do - nRef <- newIORef [] - let failingMem = FailingMemory - mockLLM = MockLLM (Right $ Message User "" defaultMessageData) nRef - chain = ConversationChain failingMem mockLLM (PromptTemplate "") - result <- invoke chain "Hi" - result @?= Left (memoryError "Memory error" Nothing Nothing) - , testCase "LLM returns error" $ do - memRef <- newIORef [] - let testMem = TestMemory memRef - msgRef <- newIORef [] - let mockLLM = MockLLM (Left $ llmError "LLM error" Nothing Nothing) msgRef - chain = ConversationChain testMem mockLLM (PromptTemplate "") - result <- invoke chain "Hi" - result @?= Left (llmError "LLM error" Nothing Nothing) - -- Verify only user message in memory - mem <- readIORef memRef - assertEqual "Only user message in memory" [Message User "Hi" defaultMessageData] mem - , testCase "Memory update after response" $ do - memRef <- newIORef [] - nRef <- newIORef [] - let testMem = TestMemory memRef - mockLLM = MockLLM (Right $ Message User "Response" defaultMessageData) nRef - chain = ConversationChain testMem mockLLM (PromptTemplate "") - _ <- invoke chain "Test" - mem <- readIORef memRef - assertEqual "Memory contains both messages" 2 (length mem) - ] diff --git a/test/Test/Langchain/Runnable/Core.hs b/test/Test/Langchain/Runnable/Core.hs deleted file mode 100644 --- a/test/Test/Langchain/Runnable/Core.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - -module Test.Langchain.Runnable.Core (tests) where - -import Data.IORef (modifyIORef, newIORef, readIORef, writeIORef) -import Langchain.Error (LangchainError, llmError) -import Langchain.Runnable.Core -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertEqual, testCase) - -newtype MockRunnable a b = MockRunnable - { runMock :: a -> IO (Either LangchainError b) - } - -instance Runnable (MockRunnable a b) where - type RunnableInput (MockRunnable a b) = a - type RunnableOutput (MockRunnable a b) = b - invoke = runMock - -tests :: TestTree -tests = - testGroup - "Runnable Tests" - [ testCase "invoke success" $ do - let mock = MockRunnable (\(s :: String) -> return $ Right (s ++ " processed")) - result <- invoke mock "input" - assertEqual "Should process input" (Right "input processed") result - , testCase "invoke error" $ do - let mock = MockRunnable (\(_ :: String) -> return $ Left (llmError "mock error" Nothing Nothing)) - result <- invoke mock "input" - assertEqual - "Should return error" - (Left (llmError "mock error" Nothing Nothing) :: Either LangchainError String) - result - , testCase "batch success" $ do - let mock = MockRunnable (\(s :: String) -> return $ Right (s ++ "!")) - result <- batch mock ["a", "b", "c"] - assertEqual "All inputs processed" (Right ["a!", "b!", "c!"]) result - , testCase "batch with error" $ do - let mock = MockRunnable $ \(s :: String) -> - if s == "b" - then return (Left (llmError "error in batch" Nothing Nothing)) - else return (Right (s ++ "!")) - result <- batch mock ["a", "b", "c"] - assertEqual "Should return first error" (Left (llmError "error in batch" Nothing Nothing)) result - , testCase "stream success" $ do - ref <- newIORef [] - let mock = MockRunnable (\(s :: String) -> return $ Right (s ++ "!")) - callback x = modifyIORef ref (++ [x]) - result <- stream mock "test" callback - readRef <- readIORef ref - assertEqual "Stream should succeed" (Right ()) result - assertEqual "Callback called with correct value" ["test!"] readRef - , testCase "stream error" $ do - ref <- newIORef [] - let mock = MockRunnable (\(_ :: String) -> return $ Left (llmError "stream error" Nothing Nothing)) - callback _ = writeIORef ref ["should not be called" :: String] - result <- stream mock "test" callback - readRef <- readIORef ref - assertEqual "Stream should return error" (Left (llmError "stream error" Nothing Nothing)) result - assertEqual "Callback not called" [] readRef - ] diff --git a/test/Test/Langchain/Runnable/Utils.hs b/test/Test/Langchain/Runnable/Utils.hs deleted file mode 100644 --- a/test/Test/Langchain/Runnable/Utils.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - -module Test.Langchain.Runnable.Utils (tests) where - -import Control.Concurrent (threadDelay) -import Data.IORef (IORef, modifyIORef, newIORef, readIORef) -import Langchain.Error (LangchainError, llmError) -import Langchain.Runnable.Core -import Langchain.Runnable.Utils -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertEqual, testCase) - -data InvocationCounter a b = InvocationCounter (IORef Int) (a -> IO (Either LangchainError b)) - -instance Runnable (InvocationCounter a b) where - type RunnableInput (InvocationCounter a b) = a - type RunnableOutput (InvocationCounter a b) = b - invoke (InvocationCounter counter f) input = do - modifyIORef counter (+ 1) - f input - -tests :: TestTree -tests = - testGroup - "Runnable Utils Tests" - [ testGroup - "WithConfig Tests" - [ testCase "WithConfig delegates to underlying runnable" $ do - let mock = MockRunnable (\s -> return $ Right (s ++ " processed")) - config = WithConfig mock () - result <- invoke config "input" - assertEqual "Should delegate to mock" (Right "input processed") result - ] - , testGroup - "Cached Tests" - [ testCase "Cached returns cached result on second call" $ do - counter <- newIORef 0 - let mock = InvocationCounter counter (\s -> return $ Right (s ++ "!")) - cachedMock <- cached mock - result1 <- invoke cachedMock "test" - _ <- readIORef counter - result2 <- invoke cachedMock "test" - count2 <- readIORef counter - assertEqual "First call result" (Right "test!") result1 - assertEqual "Second call result" (Right "test!") result2 - assertEqual "Only one invocation" 1 count2 - , testCase "Cached handles different inputs separately" $ do - counter <- newIORef 0 - let mock = InvocationCounter counter (\s -> return $ Right (s ++ "!")) - cachedMock <- cached mock - _ <- invoke cachedMock "test1" - _ <- invoke cachedMock "test2" - count <- readIORef counter - assertEqual "Two separate invocations" 2 count - ] - , testGroup - "Retry Tests" - [ testCase "Retry succeeds after one failure" $ do - counter <- newIORef 0 - let mock = InvocationCounter counter $ \_ -> do - cnt <- readIORef counter - if cnt < 1 - then return $ Left (llmError "Error" Nothing Nothing) - else return $ Right ("Success" :: String) - retryMock = Retry mock 3 5000 -- 1 retry, 5ms delay - result <- invoke retryMock ("input" :: String) - cnt <- readIORef counter - assertEqual "Retry succeeds" (Right "Success") result - assertEqual "Invoked twice" 1 cnt - , testCase "Retry exhausts retries and fails" $ do - counter <- newIORef 0 - let mock = InvocationCounter counter (\_ -> return $ Left (llmError "Error" Nothing Nothing)) - retryMock = Retry mock 2 1000 -- 2 retries - result <- invoke retryMock ("input" :: String) - cnt <- readIORef counter - assertEqual - "All retries exhausted" - (Left (llmError "Error" Nothing Nothing) :: Either LangchainError String) - result - assertEqual "Three attempts made" 3 cnt - ] - , testGroup - "WithTimeout Tests" - [ testCase "WithTimeout returns result before timeout" $ do - let mock = MockRunnable (\_ -> return $ Right "Quick response") - timeoutMock = WithTimeout mock 100000 -- 100ms timeout - result <- invoke timeoutMock ("input" :: String) - assertEqual "Returns result" (Right ("Quick response" :: String)) result - , testCase "WithTimeout triggers timeout error" $ do - let mock = MockRunnable $ \_ -> do - threadDelay 200000 -- 200ms delay - return $ Right "Too slow" - timeoutMock = WithTimeout mock 100000 -- 100ms timeout - result <- invoke timeoutMock ("input" :: String) - assertEqual - "Timeout error" - (Left (llmError "Operation timed out" Nothing Nothing) :: Either LangchainError String) - result - ] - ] - -newtype MockRunnable a b = MockRunnable {runMock :: a -> IO (Either LangchainError b)} - -instance Runnable (MockRunnable a b) where - type RunnableInput (MockRunnable a b) = a - type RunnableOutput (MockRunnable a b) = b - invoke = runMock diff --git a/test/Test/Langchain/TestHelpers.hs b/test/Test/Langchain/TestHelpers.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/TestHelpers.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- | +Module : Test.Langchain.TestHelpers +Description : Test helpers, environment filtering, and provider selection utilities +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Provides smart model selection: uses OpenRouter when API key is present, +and falls back to a local Ollama instance otherwise. +-} +module Test.Langchain.TestHelpers + ( -- * Provider selection + withAnyModel + , withOpenRouterOrOllama + + -- * OpenRouter helpers + , getOpenRouterApiKey + , newTestOpenRouter + , defaultOpenRouterModel + , defaultOpenRouterEndpoint + + -- * Ollama helpers + , isOllamaInstalled + , isOllamaRunning + , isModelAvailable + , newTestOllama + , withOllamaModel + + -- * Shared defaults + , defaultTestModel + , defaultEmbedModel + , ollamaModelName + + -- * TestLevel + , TestLevel (..) + ) where + +import Control.Exception (SomeException, try) +import Control.Monad.IO.Class (MonadIO) +import Data.Aeson (Value, decode) +import Data.Maybe (isJust) +import Data.Text (Text) +import qualified Data.Text as T +import System.Directory (findExecutable) + +import Langchain.Provider.Ollama (Ollama, configTimeout, defaultConfig, newOllama) +import Langchain.Provider.OpenAI (OpenAI, openAICompatible) +import Network.HTTP.Simple + ( getResponseBody + , getResponseStatusCode + , httpLBS + , parseRequest_ + , setRequestCheckStatus + ) +import System.Environment (lookupEnv) + +-- --------------------------------------------------------------------------- +-- Types +-- --------------------------------------------------------------------------- + +-- | Test categorization levels configured via LANGCHAIN_TEST_LEVEL environment variable +data TestLevel + = UnitLevel + | PropertyLevel + | IntegrationLevel + | E2ELevel + deriving (Eq, Ord, Show, Read) + +-- --------------------------------------------------------------------------- +-- Shared defaults +-- --------------------------------------------------------------------------- + +-- | Default Ollama model for integration tests +defaultTestModel :: Text +defaultTestModel = "qwen3.5:2b" + +-- | Fallback Ollama model +ollamaModelName :: Text +ollamaModelName = "gemma3:latest" + +-- | Default embedding model (Ollama) +defaultEmbedModel :: Text +defaultEmbedModel = "nomic-embed-text" + +-- --------------------------------------------------------------------------- +-- OpenRouter helpers +-- --------------------------------------------------------------------------- + +-- | Default OpenRouter model for integration tests +defaultOpenRouterModel :: Text +defaultOpenRouterModel = "nex-agi/nex-n2.5-mini:free" + +-- | Default OpenRouter base URL +defaultOpenRouterEndpoint :: Text +defaultOpenRouterEndpoint = "https://openrouter.ai/api" + +-- | Read OpenRouter API key from the @OPEN_ROUTER_API_KEY@ environment variable. +getOpenRouterApiKey :: IO (Maybe Text) +getOpenRouterApiKey = do + mv <- lookupEnv "OPEN_ROUTER_API_KEY" + case mv of + Just v | not (T.null (T.strip (T.pack v))) -> pure $ Just (T.strip (T.pack v)) + _ -> pure Nothing + +-- | Build an 'OpenAI' provider pointing at OpenRouter with @openrouter/free@. +newTestOpenRouter :: Text -> OpenAI +newTestOpenRouter apiKey = + openAICompatible apiKey defaultOpenRouterModel defaultOpenRouterEndpoint + +-- --------------------------------------------------------------------------- +-- Ollama helpers +-- --------------------------------------------------------------------------- + +-- | Check if the Ollama CLI executable is installed on the system PATH +isOllamaInstalled :: IO Bool +isOllamaInstalled = isJust <$> findExecutable "ollama" + +-- | Check if Ollama daemon is running on localhost:11434 +isOllamaRunning :: IO Bool +isOllamaRunning = do + eRes <- try (httpLBS $ setRequestCheckStatus $ parseRequest_ "GET http://localhost:11434/api/tags") + case eRes of + Left (_ :: SomeException) -> pure False + Right res -> pure (getResponseStatusCode res == 200) + +-- | Check if a specific model tag is available in local Ollama +isModelAvailable :: Text -> IO Bool +isModelAvailable targetModel = do + eRes <- try (httpLBS $ setRequestCheckStatus $ parseRequest_ "GET http://localhost:11434/api/tags") + case eRes of + Left (_ :: SomeException) -> pure False + Right res -> do + let body = getResponseBody res + case decode body :: Maybe Value of + Nothing -> pure False + Just _ -> pure $ T.isInfixOf targetModel (T.pack $ show body) + +-- | Execute an action with an Ollama model if available, otherwise skip cleanly. +withOllamaModel :: Text -> (Text -> IO ()) -> IO () +withOllamaModel preferredModel action = do + running <- isOllamaRunning + if not running + then do + installed <- isOllamaInstalled + if not installed + then putStrLn " [SKIPPED] Ollama is not installed" + else putStrLn " [SKIPPED] Ollama daemon is not running on http://localhost:11434" + else do + hasPref <- isModelAvailable preferredModel + if hasPref + then action preferredModel + else do + hasDef <- isModelAvailable defaultTestModel + if hasDef + then action defaultTestModel + else do + hasFallback <- isModelAvailable ollamaModelName + if hasFallback + then action ollamaModelName + else + putStrLn $ + " [SKIPPED] Neither " + ++ T.unpack preferredModel + ++ ", " + ++ T.unpack defaultTestModel + ++ ", nor " + ++ T.unpack ollamaModelName + ++ " is available in Ollama." + +-- | Build an Ollama provider with a generous timeout. +newTestOllama :: MonadIO m => Text -> m Ollama +newTestOllama modelName = + newOllama + modelName + defaultConfig + { configTimeout = 600 + } + +-- --------------------------------------------------------------------------- +-- Combined provider selection +-- --------------------------------------------------------------------------- + +{- | Run @openRouterAction@ if an OpenRouter API key is available, + otherwise fall back to @ollamaAction@. +-} +withOpenRouterOrOllama :: + -- | Action when neither OpenRouter key nor Ollama is available (e.g. skip) + IO () -> + -- | Action given an OpenRouter 'OpenAI' provider + (OpenAI -> IO ()) -> + -- | Action given an 'Ollama' provider + (Ollama -> IO ()) -> + IO () +withOpenRouterOrOllama onMissing openRouterAction ollamaAction = do + mbKey <- getOpenRouterApiKey + case mbKey of + Just key -> openRouterAction (newTestOpenRouter key) + Nothing -> do + running <- isOllamaRunning + if running + then withOllamaModel defaultTestModel (\mName -> do o <- newTestOllama mName; ollamaAction o) + else onMissing + +{- | Run a test action with OpenRouter (OpenAI-compatible) when an API key is + present in the @OPEN_ROUTER_API_KEY@ environment variable, + otherwise fall back to Ollama. +-} +withAnyModel :: + -- | Action when OpenRouter key is available + (OpenAI -> IO ()) -> + -- | Action when falling back to Ollama + (Ollama -> IO ()) -> + IO () +withAnyModel = + withOpenRouterOrOllama + ( do + installed <- isOllamaInstalled + if not installed + then putStrLn " [SKIPPED] No OpenRouter key and Ollama is not installed — skipping test" + else putStrLn " [SKIPPED] No OpenRouter key and no Ollama daemon — skipping test" + ) diff --git a/test/Test/Langchain/TextSplitter/Character.hs b/test/Test/Langchain/TextSplitter/Character.hs --- a/test/Test/Langchain/TextSplitter/Character.hs +++ b/test/Test/Langchain/TextSplitter/Character.hs @@ -11,80 +11,36 @@ tests = testGroup "Langchain.TextSplitter.Character Tests" - [ testCase "defaultCharacterSplitterOps should have correct values" $ do - chunkSize defaultCharacterSplitterOps @?= 100 - separator defaultCharacterSplitterOps @?= "\n\n" - , testCase "splitText should return empty list for empty text" $ + [ testCase "splitText returns empty list for empty text" $ splitText defaultCharacterSplitterOps "" @?= [] - , testCase "splitText should keep text as single chunk if smaller than chunk size" $ do - let text = "This is a small text" - ops = defaultCharacterSplitterOps - splitText ops text @?= [text] - , testCase "splitText should split text by separator" $ do - let text = "Paragraph 1\n\nParagraph 2\n\nParagraph 3" - ops = defaultCharacterSplitterOps - splitText ops text @?= ["Paragraph 1", "Paragraph 2", "Paragraph 3"] - , testCase "splitText should split text by chunk size" $ do - let text = - "This is a very long text that should be split into chunks because it exceeds the chunk size limit." - ops = CharacterSplitterOps {chunkSize = 20, separator = "\n\n"} - splitText ops text - @?= [ "This is a very long " - , "text that should be " - , "split into chunks be" - , "cause it exceeds the" - , " chunk size limit." - ] - , testCase "splitText should handle both separator and chunk size" $ do - let text = - "First paragraph that is quite long.\n\nSecond paragraph that is also very long and should be split." - ops = CharacterSplitterOps {chunkSize = 20, separator = "\n\n"} - splitText ops text + , testCase "splitText keeps small text as single chunk" $ + splitText defaultCharacterSplitterOps "This is a small text" @?= ["This is a small text"] + , testCase "splitText splits on separator" $ do + let ops = defaultCharacterSplitterOps + splitText ops "Paragraph 1\n\nParagraph 2\n\nParagraph 3" + @?= ["Paragraph 1", "Paragraph 2", "Paragraph 3"] + , testCase "splitText splits long text by chunk size when no separator matches" $ do + let ops = CharacterSplitterOps {chunkSize = 20, separator = "|"} + splitText ops "Thisisasinglewordwithoutanyseparators" + @?= ["Thisisasinglewordwit", "houtanyseparators"] + , testCase "splitText handles both separator and chunk size" $ do + let ops = CharacterSplitterOps {chunkSize = 20, separator = "\n\n"} + splitText + ops + "First paragraph that is quite long.\n\nSecond paragraph that is also very long and should be split." @?= [ "First paragraph that" , " is quite long." , "Second paragraph tha" , "t is also very long " , "and should be split." ] - , testCase "splitText should work with custom separator" $ do - let text = "Item 1|Item 2|Item 3|Item 4" - ops = CharacterSplitterOps {chunkSize = 100, separator = "|"} - splitText ops text @?= ["Item 1", "Item 2", "Item 3", "Item 4"] - , testCase "splitText should handle text with no separators" $ do - let text = - "ThisisasinglewordwithoutanyseparatorsthatshouldstillbesplitintochunksbasedonthechunksizeAlthoughithasnoseparatorsitcanstillbesplitproperly" - ops = CharacterSplitterOps {chunkSize = 20, separator = "|"} - splitText ops text - @?= [ "Thisisasinglewordwit" - , "houtanyseparatorstha" - , "tshouldstillbespliti" - , "ntochunksbasedonthec" - , "hunksizeAlthoughitha" - , "snoseparatorsitcanst" - , "illbesplitproperly" - ] - , testCase "splitText should handle multiple adjacent separators" $ do - let text = "Item 1\n\n\n\nItem 2\n\nItem 3" - ops = defaultCharacterSplitterOps - splitText ops text @?= ["Item 1", "Item 2", "Item 3"] - , testCase "splitText should handle text starting with separators" $ do - let text = "\n\nItem 1\n\nItem 2" - ops = defaultCharacterSplitterOps - splitText ops text @?= ["Item 1", "Item 2"] - , testCase "splitText should handle text ending with separators" $ do - let text = "Item 1\n\nItem 2\n\n" - ops = defaultCharacterSplitterOps - splitText ops text @?= ["Item 1", "Item 2"] - , testCase "splitText should handle small chunk size" $ do - let text = "abc" - ops = CharacterSplitterOps {chunkSize = 1, separator = "\n\n"} - splitText ops text @?= ["a", "b", "c"] - , testCase "splitText should handle chunk size zero" $ do - let text = "test" - ops = CharacterSplitterOps {chunkSize = 0, separator = "\n\n"} - splitText ops text @?= [] - , testCase "splitText should handle empty separator" $ do - let text = "test" - ops = CharacterSplitterOps {chunkSize = 2, separator = ""} - splitText ops text @?= ["te", "st"] + , testCase "splitText strips empty chunks from adjacent separators" $ do + splitText defaultCharacterSplitterOps "Item 1\n\n\n\nItem 2\n\nItem 3" + @?= ["Item 1", "Item 2", "Item 3"] + , testCase "splitText handles custom pipe separator" $ do + let ops = CharacterSplitterOps {chunkSize = 100, separator = "|"} + splitText ops "Item 1|Item 2|Item 3" @?= ["Item 1", "Item 2", "Item 3"] + , testCase "splitText with empty separator splits by character chunk" $ do + let ops = CharacterSplitterOps {chunkSize = 2, separator = ""} + splitText ops "test" @?= ["te", "st"] ] diff --git a/test/Test/Langchain/TextSplitter/CodeSpec.hs b/test/Test/Langchain/TextSplitter/CodeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/TextSplitter/CodeSpec.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.TextSplitter.CodeSpec (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.TextSplitter.Code + +tests :: TestTree +tests = + testGroup + "Langchain.TextSplitter.CodeSpec" + [ testCase "Splits Haskell source code on declaration boundaries" $ do + let hsCode = + "module MyModule where\n\ndata Person = Person { name :: String }\n\ndata Animal = Dog | Cat\n\nmyFunc :: Int -> Int\nmyFunc x = x + 1" + ops = CodeSplitterOps Haskell 50 0 + chunks = splitCode ops hsCode + assertBool "Multiple chunks produced" (length chunks >= 2) + , testCase "Splits Python source code on def/class boundaries" $ do + let pyCode = + "class Calculator:\n def add(self, a, b):\n return a + b\n\ndef main():\n calc = Calculator()\n print(calc.add(2, 3))" + ops = CodeSplitterOps Python 60 0 + chunks = splitCode ops pyCode + assertBool "Produced chunks for Python" (length chunks >= 2) + , testCase "Splits Rust code on fn and struct boundaries" $ do + let rsCode = + "struct Point {\n x: f64,\n y: f64,\n}\n\nfn calculate_distance(p1: Point, p2: Point) -> f64 {\n 0.0\n}" + ops = CodeSplitterOps Rust 50 0 + chunks = splitCode ops rsCode + assertBool "Produced chunks for Rust" (length chunks >= 2) + ] diff --git a/test/Test/Langchain/TextSplitter/MarkdownSpec.hs b/test/Test/Langchain/TextSplitter/MarkdownSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/TextSplitter/MarkdownSpec.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.TextSplitter.MarkdownSpec (tests) where + +import qualified Data.Map.Strict as Map +import qualified Data.Text.Lazy as TL +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.TextSplitter.Markdown + +tests :: TestTree +tests = + testGroup + "Langchain.TextSplitter.MarkdownSpec" + [ testCase "Splits markdown and preserves header hierarchy in metadata" $ do + let doc = + "# Title\n\nIntroductory text.\n\n## Section 1\n\nSection 1 details.\n\n### SubSection A\n\nSubSection content.\n\n## Section 2\n\nSection 2 details." + chunks = splitMarkdownToChunks defaultMarkdownSplitterOps doc + case chunks of + [c1, _c2, subSecChunk, _c4] -> do + chunkHeaders c1 @?= Map.singleton "Header 1" "Title" + Map.lookup "Header 1" (chunkHeaders subSecChunk) @?= Just "Title" + Map.lookup "Header 2" (chunkHeaders subSecChunk) @?= Just "Section 1" + Map.lookup "Header 3" (chunkHeaders subSecChunk) @?= Just "SubSection A" + _ -> assertFailure ("Expected 4 chunks, got " ++ show (length chunks)) + , testCase "Section 2 clears previous subsection headers" $ do + let doc = + "# Title\n\n## Section 1\n\n### SubSection\n\nDetails.\n\n## Section 2\n\nNew section." + chunks = splitMarkdownToChunks defaultMarkdownSplitterOps doc + case chunks of + [_, _, _, sec2Chunk] -> do + Map.lookup "Header 2" (chunkHeaders sec2Chunk) @?= Just "Section 2" + Map.lookup "Header 3" (chunkHeaders sec2Chunk) @?= Nothing + _ -> assertFailure ("Expected 4 chunks, got " ++ show (length chunks)) + , testCase "Plain text markdown splitting produces non-empty chunks" $ do + let doc = "# Main\n\nBody paragraph 1.\n\n## Sub\n\nBody paragraph 2." + chunks = splitMarkdown defaultMarkdownSplitterOps doc + case chunks of + (firstChunk : _) -> do + length chunks @?= 2 + assertBool "Chunk contains Main" ("Main" `TL.isInfixOf` firstChunk) + [] -> assertFailure "Expected chunks to be non-empty" + ] diff --git a/test/Test/Langchain/TextSplitter/RecursiveCharacterSpec.hs b/test/Test/Langchain/TextSplitter/RecursiveCharacterSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/TextSplitter/RecursiveCharacterSpec.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.TextSplitter.RecursiveCharacterSpec (tests) where + +import Data.Int (Int64) +import qualified Data.Text.Lazy as TL +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.TextSplitter.RecursiveCharacter + +splitTextRecursiveLegacy :: RecursiveCharacterSplitterOps -> TL.Text -> [TL.Text] +splitTextRecursiveLegacy _ "" = [] +splitTextRecursiveLegacy ops text = + filter (not . TL.null) $ splitRecursive (separators ops) text + where + cSize = chunkSize ops + cOverlap = chunkOverlap ops + + splitRecursive :: [TL.Text] -> TL.Text -> [TL.Text] + splitRecursive [] t + | TL.length t <= cSize = [t] + | otherwise = splitByLength cSize t + splitRecursive (sep : restSeps) t + | TL.length t <= cSize = [t] + | otherwise = + if sep == "" + then splitByLength cSize t + else + let parts = if TL.null sep then map TL.singleton (TL.unpack t) else TL.splitOn sep t + goodParts = filter (not . TL.null) parts + in if length goodParts <= 1 + then splitRecursive restSeps t + else mergeAndRecurse restSeps sep goodParts + + mergeAndRecurse :: [TL.Text] -> TL.Text -> [TL.Text] -> [TL.Text] + mergeAndRecurse restSeps sep parts = + let subChunks = concatMap (\p -> if TL.length p > cSize then splitRecursive restSeps p else [p]) parts + in mergeChunksWithOverlapLegacy cSize cOverlap sep subChunks + + splitByLength :: Int64 -> TL.Text -> [TL.Text] + splitByLength len t + | TL.null t = [] + | otherwise = + let (chunk, remainder) = TL.splitAt len t + in chunk : splitByLength len remainder + +mergeChunksWithOverlapLegacy :: Int64 -> Int64 -> TL.Text -> [TL.Text] -> [TL.Text] +mergeChunksWithOverlapLegacy _ _ _ [] = [] +mergeChunksWithOverlapLegacy maxLen overlapLen sep pieces = go [] 0 [] pieces + where + sepLen = TL.length sep + + go :: [TL.Text] -> Int64 -> [TL.Text] -> [TL.Text] -> [TL.Text] + go acc _ currentAcc [] = + if null currentAcc + then reverse acc + else reverse (joinPieces sep (reverse currentAcc) : acc) + go acc currentLen currentAcc (p : ps) = + let pieceLen = TL.length p + additionalLen = if null currentAcc then pieceLen else pieceLen + sepLen + in if currentLen + additionalLen <= maxLen + then go acc (currentLen + additionalLen) (p : currentAcc) ps + else + let finishedChunk = joinPieces sep (reverse currentAcc) + newAcc = finishedChunk : acc + overlapPieces = computeOverlapPieces overlapLen sep (reverse currentAcc) + overlapLenActual = sum (map TL.length overlapPieces) + fromIntegral (max 0 (length overlapPieces - 1)) * sepLen + in if pieceLen > maxLen + then go (p : newAcc) 0 [] ps + else + go + newAcc + (overlapLenActual + pieceLen + if null overlapPieces then 0 else sepLen) + (p : reverse overlapPieces) + ps + + joinPieces :: TL.Text -> [TL.Text] -> TL.Text + joinPieces = TL.intercalate + + computeOverlapPieces :: Int64 -> TL.Text -> [TL.Text] -> [TL.Text] + computeOverlapPieces targetOverlap s ps + | targetOverlap <= 0 = [] + | otherwise = takeWhileOverlap targetOverlap s (reverse ps) [] + + takeWhileOverlap :: Int64 -> TL.Text -> [TL.Text] -> [TL.Text] -> [TL.Text] + takeWhileOverlap _ _ [] acc = acc + takeWhileOverlap target s (p : ps) acc = + let curLen = sum (map TL.length (p : acc)) + fromIntegral (length acc) * TL.length s + in if curLen <= target + then takeWhileOverlap target s ps (p : acc) + else acc + +legacyEqCase :: RecursiveCharacterSplitterOps -> TL.Text -> Assertion +legacyEqCase ops txt = + splitTextRecursive ops txt @?= splitTextRecursiveLegacy ops txt + +tests :: TestTree +tests = + testGroup + "Langchain.TextSplitter.RecursiveCharacterSpec" + [ testCase "Empty text returns empty chunk list" $ + splitTextRecursive defaultRecursiveCharacterSplitterOps "" @?= [] + , testCase "Legacy eq: exact chunkSize boundary" $ do + let ops = defaultRecursiveCharacterSplitterOps {chunkSize = 5, chunkOverlap = 0} + legacyEqCase ops "abcde" + , testCase "Legacy eq: chunkSize + 1 boundary" $ do + let ops = defaultRecursiveCharacterSplitterOps {chunkSize = 5, chunkOverlap = 0} + legacyEqCase ops "abcdef" + , testCase "Legacy eq: chunkSize = 1" $ do + let ops = defaultRecursiveCharacterSplitterOps {chunkSize = 1, chunkOverlap = 0} + legacyEqCase ops "abcdef" + , testCase "Legacy eq: separators empty list fallback" $ do + let ops = defaultRecursiveCharacterSplitterOps {chunkSize = 3, chunkOverlap = 0, separators = []} + legacyEqCase ops "abcdefgh" + , testCase "Legacy eq: separators only empty string fallback" $ do + let ops = defaultRecursiveCharacterSplitterOps {chunkSize = 3, chunkOverlap = 0, separators = [""]} + legacyEqCase ops "abcdefgh" + , testCase "Legacy eq: fallback to rest separators when first separator absent" $ do + let ops = + defaultRecursiveCharacterSplitterOps + { chunkSize = 6 + , chunkOverlap = 0 + , separators = ["@@", "\n", " ", ""] + } + legacyEqCase ops "aa bb cc" + , testCase "Legacy eq: drops empties from adjacent and edge separators" $ do + let ops = defaultRecursiveCharacterSplitterOps {chunkSize = 3, chunkOverlap = 0} + legacyEqCase ops "\n\nA\n\n\n\nB\n\n" + , testCase "Legacy eq: overlap = 0" $ do + let ops = defaultRecursiveCharacterSplitterOps {chunkSize = 5, chunkOverlap = 0, separators = ["|", ""]} + legacyEqCase ops "ab|cd|ef|gh" + , testCase "Legacy eq: overlap = chunkSize" $ do + let ops = defaultRecursiveCharacterSplitterOps {chunkSize = 5, chunkOverlap = 5, separators = ["|", ""]} + legacyEqCase ops "ab|cd|ef|gh" + , testCase "Legacy eq: overlap > chunkSize" $ do + let ops = defaultRecursiveCharacterSplitterOps {chunkSize = 5, chunkOverlap = 9, separators = ["|", ""]} + legacyEqCase ops "ab|cd|ef|gh|ij" + , testCase "Legacy eq: multi-character separator with overlap" $ do + let ops = defaultRecursiveCharacterSplitterOps {chunkSize = 8, chunkOverlap = 3, separators = ["||", ""]} + legacyEqCase ops "ab||cd||ef||gh" + , testCase "Legacy eq: oversized piece path" $ do + let ops = defaultRecursiveCharacterSplitterOps {chunkSize = 4, chunkOverlap = 2, separators = ["|", ""]} + legacyEqCase ops "abcdefgh|ij|kl" + , testCase "Legacy eq: mixed separators and recursive fallback" $ do + let ops = + defaultRecursiveCharacterSplitterOps + { chunkSize = 10 + , chunkOverlap = 2 + , separators = ["\n\n", "\n", " ", ""] + } + legacyEqCase ops "p1 line1\n\np2 has many words\nline2" + , testCase "Invariant: no chunk exceeds chunkSize for valid config" $ do + let ops = defaultRecursiveCharacterSplitterOps {chunkSize = 7, chunkOverlap = 2} + chunks = splitTextRecursive ops "a aa aaa aaaa aaaaa" + assertBool "All chunks must be <= chunkSize" (all (\c -> TL.length c <= chunkSize ops) chunks) + , testCase "Invariant: all chunks are non-empty" $ do + let ops = defaultRecursiveCharacterSplitterOps {chunkSize = 4, chunkOverlap = 1} + chunks = splitTextRecursive ops "\n\nA\n\n\n\nB\n\n" + assertBool "No empty chunks" ((not . any TL.null) chunks) + ] diff --git a/test/Test/Langchain/TextSplitter/TokenSpec.hs b/test/Test/Langchain/TextSplitter/TokenSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/TextSplitter/TokenSpec.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.TextSplitter.TokenSpec (tests) where + +import qualified Data.Text.Lazy as TL +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.TextSplitter.Token + +tests :: TestTree +tests = + testGroup + "Langchain.TextSplitter.TokenSpec" + [ testCase "Empty text returns empty list" $ do + splitByTokens defaultTokenSplitterOps "" @?= [] + , testCase "Splits text into token-bounded chunks" $ do + let text = TL.unwords (replicate 50 "token") + ops = defaultTokenSplitterOps {maxTokens = 15, tokenOverlap = 0} + chunks = splitByTokens ops text + assertBool "Multiple chunks produced" (length chunks >= 3) + assertBool "No chunk exceeds 15 tokens" (all (\c -> countTokensApprox c <= 15) chunks) + , testCase "Token splitter preserves words across chunks" $ do + let text = "one two three four five six seven eight nine ten" + ops = defaultTokenSplitterOps {maxTokens = 4, tokenOverlap = 0} + chunks = splitByTokens ops text + assertBool "Produced chunks" (length chunks >= 2) + ] diff --git a/test/Test/Langchain/Tool/AdvancedToolsSpec.hs b/test/Test/Langchain/Tool/AdvancedToolsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Tool/AdvancedToolsSpec.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Tool.AdvancedToolsSpec (tests) where + +import Control.Concurrent.Async (wait) +import Control.Monad.Except (runExceptT) +import Data.Aeson (FromJSON, ToJSON, Value (..), object) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import GHC.Generics (Generic) +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Tool.Async +import Langchain.Tool.Core (createTool) +import Langchain.Tool.GenericSchema + +data SearchArgs = SearchArgs + { queryTerm :: Text + , maxResults :: Int + , filterCategory :: Maybe Text + } + deriving (Show, Eq, Generic, ToJSON, FromJSON, DeriveToolSchema) + +tests :: TestTree +tests = + testGroup + "Langchain.Tool.AdvancedToolsSpec" + [ testCase "deriveToolSchema generates valid JSON Schema object with properties" $ do + let schemaVal = deriveToolSchema (Proxy :: Proxy SearchArgs) + case schemaVal of + Object o -> assertBool "Schema contains type or properties" (not $ null o) + _ -> assertFailure "Expected Object schema" + , testCase "executeToolAsync runs tool in background thread" $ do + let sampleTool = + createTool + "async_sample" + "Async test" + (object []) + (\_ -> pure $ Right "Completed async") + asyncHandle <- executeToolAsync sampleTool (object []) + res <- wait asyncHandle + res @?= Right "Completed async" + , testCase "executeToolBatchConcurrently runs multiple tool calls concurrently" $ do + let sampleTool = + createTool + "batch_sample" + "Batch test" + (object []) + (\_ -> pure $ Right "Batch OK") + res <- runExceptT $ executeToolBatchConcurrently [(sampleTool, object []), (sampleTool, object [])] + res @?= Right ["Batch OK", "Batch OK"] + ] diff --git a/test/Test/Langchain/Tool/Calculator.hs b/test/Test/Langchain/Tool/Calculator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Tool/Calculator.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Tool.Calculator (tests) where + +import Data.Aeson (object, (.=)) +import Data.Text (Text) +import Langchain.Core.Tool (toolExecute) +import Langchain.Tool.Calculator +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "Langchain.Tool.Calculator" + [ testCase "calculatorTool evaluates expression via Tool interface" $ do + res <- toolExecute calculatorTool (object ["expression" .= ("2 + 2" :: Text)]) + res @?= Right "4.0" + , testCase "calculatorTool handles multiplication" $ do + res <- toolExecute calculatorTool (object ["expression" .= ("3 * 4" :: Text)]) + res @?= Right "12.0" + ] diff --git a/test/Test/Langchain/Tool/Core.hs b/test/Test/Langchain/Tool/Core.hs deleted file mode 100644 --- a/test/Test/Langchain/Tool/Core.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - -module Test.Langchain.Tool.Core (tests) where - -import Data.Aeson (decode) -import Data.Either (isLeft) -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T -import Test.Tasty -import Test.Tasty.HUnit - -import Langchain.Tool.Calculator -import Langchain.Tool.Core -import Langchain.Tool.WebScraper -import Langchain.Tool.WikipediaTool - -newtype MockTool = MockTool Text - deriving (Show, Eq) - -instance Tool MockTool where - type Input MockTool = Text - type Output MockTool = Text - toolName (MockTool name) = name - toolDescription _ = "A mock tool for testing" - runTool _ input = return $ "Processed: " <> input - -tests :: TestTree -tests = - testGroup - "Tool Tests" - [ testCase "MockTool implements Tool interface correctly" testMockTool - , testCase "WikipediaTool default values" testWikipediaToolDefaults - , testCase "WikipediaTool tool name and description" testWikipediaToolMetadata - , testCase "WikipediaTool search functionality" testWikipediaToolSearch - , testCase "SearchResponse parsing" testSearchResponseParsing - , testCase "PageResponse parsing" testPageResponseParsing - , testCase "WebScraper Tool" testWebScraperTool - , testCalculatorTool - ] - -testCalculatorTool :: TestTree -testCalculatorTool = - testGroup - "Langchain.Tool.Calculator" - [ parseExpressionTests - , evaluateExpressionTests - , calculatorToolTests - ] - --- | Test cases for parseExpression -parseExpressionTests :: TestTree -parseExpressionTests = - testGroup - "parseExpression" - [ testCase "Parses integer" $ - parseExpression "123" @?= Right (Number_ 123.0) - , testCase "Parses decimal" $ - parseExpression "45.67" @?= Right (Number_ 45.67) - , testCase "Handles addition" $ - parseExpression "2+3" @?= Right (Add (Number_ 2) (Number_ 3)) - , testCase "Handles subtraction" $ - parseExpression "5 - 1" @?= Right (Sub (Number_ 5) (Number_ 1)) - , testCase "Handles multiplication" $ - parseExpression "4*2" @?= Right (Mul (Number_ 4) (Number_ 2)) - , testCase "Handles division" $ - parseExpression "8 / 2" @?= Right (Div (Number_ 8) (Number_ 2)) - , testCase "Handles exponentiation" $ - parseExpression "2^3" @?= Right (Pow (Number_ 2) (Number_ 3)) - , testCase "Respects operator precedence" $ - parseExpression "2 + 3 * 4" @?= Right (Add (Number_ 2) (Mul (Number_ 3) (Number_ 4))) - , testCase "Respects parentheses" $ - parseExpression "(2 + 3) * 4" @?= Right (Mul (Add (Number_ 2) (Number_ 3)) (Number_ 4)) - , testCase "Fails on invalid input" $ - isLeft (parseExpression "hello") @? "Expected parse failure for 'hello'" - ] - --- | Test cases for evaluateExpression -evaluateExpressionTests :: TestTree -evaluateExpressionTests = - testGroup - "evaluateExpression" - [ testCase "Evaluates Num" $ - evaluateExpression (Number_ 5) @?= 5.0 - , testCase "Evaluates Add" $ - evaluateExpression (Add (Number_ 2) (Number_ 3)) @?= 5.0 - , testCase "Evaluates Mul" $ - evaluateExpression (Mul (Number_ 3) (Number_ 4)) @?= 12.0 - , testCase "Evaluates Pow" $ - evaluateExpression (Pow (Number_ 2) (Number_ 3)) @?= 8.0 - ] - --- | Test cases for CalculatorTool -calculatorToolTests :: TestTree -calculatorToolTests = - testGroup - "CalculatorTool" - [ testCase "Computes 2 + 3 * 4" $ do - result <- runTool CalculatorTool "2 + 3 * 4" - result @?= Right 14.0 - , testCase "Computes (2 + 3) * 4" $ do - result <- runTool CalculatorTool "(2 + 3) * 4" - result @?= Right 20.0 - , testCase "Computes 2 ^ 3" $ do - result <- runTool CalculatorTool "2 ^ 3" - result @?= Right 8.0 - , testCase "Fails on invalid expression" $ do - let badExpr = "2 +" - errOrRes <- runTool CalculatorTool badExpr - case errOrRes of - Left _ -> return () - Right _ -> assertFailure "Expected error when parsing invalid expression" - ] - -testWebScraperTool :: Assertion -testWebScraperTool = do - eRes <- runTool WebScraper "https://hackage.haskell.org/package/scalpel-0.6.2.2" - assertBool "Scraper should contain stuff like title" $ do - case eRes of - Left _ -> False - Right r -> do - T.isInfixOf "Scalpel is a web scraping library inspired by libraries like" r - -testMockTool :: Assertion -testMockTool = do - let mockTool = MockTool "TestTool" - - assertEqual "toolName should return the name" "TestTool" (toolName mockTool) - - assertEqual - "toolDescription should return description" - "A mock tool for testing" - (toolDescription mockTool) - - result <- runTool mockTool "test input" - assertEqual - "runTool should process input correctly" - "Processed: test input" - result - -testWikipediaToolDefaults :: Assertion -testWikipediaToolDefaults = do - let tool = defaultWikipediaTool - - assertEqual - "Default topK should be 2" - defaultTopK - (topK tool) - - assertEqual - "Default docMaxChars should be 2000" - defaultDocMaxChars - (docMaxChars tool) - - assertEqual - "Default language code should be 'en'" - defaultLanguageCode - (languageCode tool) - -testWikipediaToolMetadata :: Assertion -testWikipediaToolMetadata = do - let tool = defaultWikipediaTool - - assertEqual - "WikipediaTool name should be 'Wikipedia'" - "Wikipedia" - (toolName tool) - - assertBool - "WikipediaTool description should mention Wikipedia" - (T.isInfixOf "Wikipedia" (toolDescription tool)) - --- TODO: Actually use the WikipediaTool here -testWikipediaToolSearch :: Assertion -testWikipediaToolSearch = do - let customTool = - WikipediaTool - { topK = 1 - , docMaxChars = 10 - , languageCode = "en" - } - - assertEqual "Custom tool should have topK = 1" 1 (topK customTool) - assertEqual "Custom tool should truncate to 10 chars" 10 (docMaxChars customTool) - --- Test JSON parsing for SearchResponse -testSearchResponseParsing :: Assertion -testSearchResponseParsing = do - let jsonStr = - "{\"query\": {\"search\": [{\"ns\": 0, \"title\": \"Haskell\", \"pageid\": 12345, \"size\": 1000, \"wordcount\": 200, \"snippet\": \"Haskell is a functional language\", \"timestamp\": \"2023-01-01\"}]}}" - parsed = decode jsonStr :: Maybe SearchResponse - - case parsed of - Nothing -> assertFailure "Failed to parse SearchResponse JSON" - Just SearchResponse {..} -> do - let searchResults = search query - assertBool "Should have at least one search result" (not $ null searchResults) - case searchResults of - (firstResult : _) -> do - assertEqual "Page ID should match" 12345 (pageid firstResult) - assertEqual "Title should match" "Haskell" (title_ firstResult) - _ -> pure () - -testPageResponseParsing :: Assertion -testPageResponseParsing = do - let jsonStr = - "{\"query\": {\"pages\": {\"12345\": {\"title\": \"Haskell\", \"extract\": \"Haskell is a functional programming language.\"}}}}" - parsed = decode jsonStr :: Maybe PageResponse - - case parsed of - Nothing -> assertFailure "Failed to parse PageResponse JSON" - Just (PageResponse (Pages pagesMap)) -> do - let maybePage = M.lookup "12345" pagesMap - case maybePage of - Nothing -> assertFailure "Expected page with ID 12345 not found" - Just page -> do - assertEqual "Page title should match" "Haskell" (title page) - assertEqual - "Page extract should match" - "Haskell is a functional programming language." - (extract page) diff --git a/test/Test/Langchain/Tool/FileSystem.hs b/test/Test/Langchain/Tool/FileSystem.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Tool/FileSystem.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Tool.FileSystem (tests) where + +import Data.Aeson (object, (.=)) +import Data.Text (Text) +import qualified Data.Text as T +import Langchain.Core.Tool (toolExecute) +import Langchain.Tool.FileSystem +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "Langchain.Tool.FileSystem" + [ testCase "writeFileTool and readFileTool perform I/O correctly" $ do + withSystemTempDirectory "tool-test" $ \dir -> do + let filePath = T.pack (dir "test.txt") + content = "Hello, langchain-hs!" + wRes <- toolExecute writeFileTool (object ["path" .= filePath, "content" .= content]) + assertBool "Write should succeed" (case wRes of Right _ -> True; _ -> False) + + rRes <- toolExecute readFileTool (object ["path" .= filePath]) + rRes @?= Right content + , testCase "listDirTool lists created files" $ do + withSystemTempDirectory "tool-test" $ \dir -> do + let filePath = T.pack (dir "sample.txt") + _ <- toolExecute writeFileTool (object ["path" .= filePath, "content" .= ("content" :: Text)]) + lRes <- toolExecute listDirTool (object ["path" .= T.pack dir]) + case lRes of + Left err -> assertFailure $ "Unexpected error: " ++ show err + Right filesTxt -> assertBool "Should contain sample.txt" ("sample.txt" `T.isInfixOf` filesTxt) + ] diff --git a/test/Test/Langchain/Tool/Shell.hs b/test/Test/Langchain/Tool/Shell.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Tool/Shell.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Tool.Shell (tests) where + +import Data.Aeson (object, (.=)) +import Data.Text (Text) +import qualified Data.Text as T +import Langchain.Core.Tool (toolExecute) +import Langchain.Tool.Shell (shellTool) +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "Langchain.Tool.Shell" + [ testCase "shellTool executes echo command correctly" $ do + res <- toolExecute shellTool (object ["command" .= ("echo 'hello shell'" :: Text)]) + case res of + Left err -> assertFailure ("shellTool failed: " ++ show err) + Right out -> out @?= "hello shell" + , testCase "shellTool handles non-zero exit code without crash" $ do + res <- toolExecute shellTool (object ["command" .= ("exit 2" :: Text)]) + case res of + Left err -> assertFailure ("shellTool failed with error: " ++ show err) + Right out -> assertBool "Contains exit code" ("exited with code" `T.isInfixOf` out) + ] diff --git a/test/Test/Langchain/VectorStore/Core.hs b/test/Test/Langchain/VectorStore/Core.hs --- a/test/Test/Langchain/VectorStore/Core.hs +++ b/test/Test/Langchain/VectorStore/Core.hs @@ -1,15 +1,17 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Test.Langchain.VectorStore.Core (tests) where +import Control.Monad.Except (runExceptT) import Data.Either (fromRight, isRight) import Data.Int (Int64) import Data.Map (empty) import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, listToMaybe) import Test.Tasty import Test.Tasty.HUnit -import Data.Maybe (fromMaybe, listToMaybe) import Langchain.DocumentLoader.Core (Document (..)) import Langchain.Embeddings.Core import Langchain.VectorStore.Core @@ -19,12 +21,12 @@ deriving (Show, Eq) instance Embeddings MockEmbeddings where - embedQuery _ "World" = pure $ Right [1.0, 0.1, 0.1] - embedQuery _ "Meet you" = pure $ Right [0.1, 0.1, 1.0] - embedQuery _ "Both" = pure $ Right [0.5, 0.5, 0.5] - embedQuery _ _ = pure $ Right [0.0, 0.0, 0.0] + embedQuery _ "World" = pure [1.0, 0.1, 0.1] + embedQuery _ "Meet you" = pure [0.1, 0.1, 1.0] + embedQuery _ "Both" = pure [0.5, 0.5, 0.5] + embedQuery _ _ = pure [0.0, 0.0, 0.0] - embedDocuments _ docs = pure $ Right $ map determineEmbedding docs + embedDocuments _ docs = pure $ map determineEmbedding docs where determineEmbedding doc | doc == Document "Hello World" empty = [1.0, 0.1, 0.1] @@ -70,7 +72,7 @@ , testCase "fromDocuments should create store with documents" $ do let model = MockEmbeddings docs = createTestDocs - result <- fromDocuments model docs + result <- runExceptT $ fromDocuments model docs assertBool "Expected Right result" (isRight result) let vs = fromRight (emptyInMemoryVectorStore model) result Map.size (store vs) @?= 2 @@ -78,13 +80,13 @@ let model = MockEmbeddings vs = emptyInMemoryVectorStore model docs = createTestDocs - result <- addDocuments vs docs + result <- runExceptT $ addDocuments vs docs assertBool "Expected Right result" (isRight result) let updatedVs = fromRight vs result Map.size (store updatedVs) @?= 2 let newDoc = Document "Something completely different" empty - result2 <- addDocuments updatedVs [newDoc] + result2 <- runExceptT $ addDocuments updatedVs [newDoc] assertBool "Expected Right result" (isRight result2) let finalVs = fromRight updatedVs result2 Map.size (store finalVs) @?= 3 @@ -92,10 +94,10 @@ let model = MockEmbeddings vs = emptyInMemoryVectorStore model docs = createTestDocs - result <- addDocuments vs docs + result <- runExceptT $ addDocuments vs docs let updatedVs = fromRight vs result - deleteResult <- delete updatedVs [1] + deleteResult <- runExceptT $ delete updatedVs [1] assertBool "Expected Right result" (isRight deleteResult) let afterDeleteVs = fromRight updatedVs deleteResult Map.size (store afterDeleteVs) @?= 1 @@ -105,48 +107,24 @@ let model = MockEmbeddings vs = emptyInMemoryVectorStore model docs = createTestDocs - result <- addDocuments vs docs - let updatedVs = fromRight vs result - - -- Search for "World" - should return "Hello World" - searchResult1 <- similaritySearch updatedVs "World" 1 - assertBool "Expected Right result" (isRight searchResult1) - let docs1 = fromRight [] searchResult1 + result <- runExceptT $ do + uVs <- addDocuments vs docs + similaritySearch uVs "World" 1 + assertBool "Expected Right result" (isRight result) + let docs1 = fromRight [] result length docs1 @?= 1 fromMaybe (Document "" empty) (listToMaybe docs1) @?= Document "Hello World" empty - - -- Search for "Meet you" - should return "Nice to meet you" - searchResult2 <- similaritySearch updatedVs "Meet you" 1 - assertBool "Expected Right result" (isRight searchResult2) - let docs2 = fromRight [] searchResult2 - length docs2 @?= 1 - fromMaybe (Document "" empty) (listToMaybe docs2) @?= Document "Nice to meet you" empty - - -- Search for both documents - searchResult3 <- similaritySearch updatedVs "Both" 2 - assertBool "Expected Right result" (isRight searchResult3) - let docs3 = fromRight [] searchResult3 - length docs3 @?= 2 , testCase "similaritySearchByVector should find similar documents" $ do let model = MockEmbeddings vs = emptyInMemoryVectorStore model docs = createTestDocs - result <- addDocuments vs docs - let updatedVs = fromRight vs result - - -- Search with vector similar to "Hello World" - searchResult1 <- similaritySearchByVector updatedVs [1.0, 0.1, 0.1] 1 - assertBool "Expected Right result" (isRight searchResult1) - let docs1 = fromRight [] searchResult1 + result <- runExceptT $ do + uVs <- addDocuments vs docs + similaritySearchByVector uVs [1.0, 0.1, 0.1] 1 + assertBool "Expected Right result" (isRight result) + let docs1 = fromRight [] result length docs1 @?= 1 fromMaybe (Document "" empty) (listToMaybe docs1) @?= Document "Hello World" empty - - -- Search with vector similar to "Nice to meet you" - searchResult2 <- similaritySearchByVector updatedVs [0.1, 0.1, 1.0] 1 - assertBool "Expected Right result" (isRight searchResult2) - let docs2 = fromRight [] searchResult2 - length docs2 @?= 1 - fromMaybe (Document "" empty) (listToMaybe docs2) @?= Document "Nice to meet you" empty ] tests :: TestTree diff --git a/test/Test/Langchain/VectorStore/SqliteVecSpec.hs b/test/Test/Langchain/VectorStore/SqliteVecSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/VectorStore/SqliteVecSpec.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.VectorStore.SqliteVecSpec (tests) where + +import Control.Monad.Except (runExceptT) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.DocumentLoader.Core (Document (..)) +import Langchain.Embeddings.Core (Embeddings (..)) +import Langchain.VectorStore.Core (VectorStore (..)) +import Langchain.VectorStore.SqliteVec + +data DeterministicMockEmbeddings = DeterministicMockEmbeddings + +instance Embeddings DeterministicMockEmbeddings where + embedDocuments _ docs = pure $ map (mockEmbed . TL.toStrict . pageContent) docs + embedQuery _ q = pure $ mockEmbed q + +mockEmbed :: Text -> [Float] +mockEmbed t = + let len = fromIntegral (T.length t) :: Float + isHaskell = if "Haskell" `T.isInfixOf` t then 1.0 else 0.0 + in [isHaskell, len / 100.0, 0.5] + +tests :: TestTree +tests = + testGroup + "Langchain.VectorStore.SqliteVecSpec" + [ testCase "SqliteVecStore adds documents and performs similarity search" $ do + withSystemTempDirectory "sqlite-vec-test" $ \tmpDir -> do + let dbPath = tmpDir "vectors.db" + emb = DeterministicMockEmbeddings + res <- runExceptT $ do + store <- newSqliteVecStore dbPath emb + let doc1 = Document "Haskell is purely functional" Map.empty + doc2 = Document "Python is dynamically typed" Map.empty + _ <- addDocuments store [doc1, doc2] + similaritySearch store "Haskell programming" 1 + case res of + Left err -> assertFailure ("SqliteVecStore failed: " ++ show err) + Right [topDoc] -> + pageContent topDoc @?= "Haskell is purely functional" + Right docs -> + assertFailure ("Expected exactly 1 document, got: " ++ show (length docs)) + ]