diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog for `langchain-haskell` + +All notable changes to this project will be documented in this file. + +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/). + +## Unreleased + +## 0.1.0.0 - YYYY-MM-DD diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2025 Tushar Adhatrao + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,88 @@ +# πŸ¦œοΈπŸ”—LangChain Haskell + +⚑ Building applications with LLMs through composability in Haskell! ⚑ + +## Introduction + +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. + +## Features + +- **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. + +## Current Supported Providers + + - Ollama + - More to come... + +## Installation + +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 >= 4.7 && < 5 + - langchain-hs +``` +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: + +```haskell +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +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 + 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) +``` + +## Documentation + +Documentation will soon be available on hackage. + +## Examples + +Explore the `examples` directory in the repository for more use cases, including: + +- **Conversational Agents**: Building chatbots that maintain context. +- **Document Q&A**: Answering questions based on the content of provided documents. +- **Tool Use**: Creating agents that can use external tools to fetch information or perform calculations. + +## Contributing + +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. + +## License + +This project is licensed under the MIT License. See the [LICENSE](LICENSE) file for details. + +## 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/langchain-hs.cabal b/langchain-hs.cabal new file mode 100644 --- /dev/null +++ b/langchain-hs.cabal @@ -0,0 +1,117 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: langchain-hs +version: 0.0.1.0 +synopsis: Haskell implementation of Langchain +description: Build LLM-powered applications in Haskell. +category: Web +homepage: https://github.com/tusharad/langchain-hs#readme +bug-reports: https://github.com/tusharad/langchain-hs/issues +author: tushar +maintainer: tusharadhatrao@gmail.com +copyright: 2025 tushar +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/tusharad/langchain-hs + +library + exposed-modules: + Langchain.Agents.Core + Langchain.Agents.React + Langchain.Callback + Langchain.DocumentLoader.Core + Langchain.DocumentLoader.FileLoader + Langchain.DocumentLoader.PdfLoader + Langchain.Embeddings.Core + Langchain.Embeddings.Ollama + Langchain.LLM.Core + Langchain.LLM.Ollama + Langchain.LLM.OpenAI + Langchain.Memory.Core + Langchain.OutputParser.Core + Langchain.PromptTemplate + Langchain.Retriever.Core + Langchain.Retriever.MultiQueryRetriever + Langchain.Runnable.Chain + Langchain.Runnable.ConversationChain + Langchain.Runnable.Core + Langchain.Runnable.Utils + Langchain.TextSplitter.Character + Langchain.Tool.Core + Langchain.Tool.WebScraper + Langchain.Tool.WikipediaTool + Langchain.VectorStore.Core + Langchain.VectorStore.InMemory + other-modules: + Paths_langchain_hs + hs-source-dirs: + src + 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.* + , base >=4.7 && <5 + , bytestring >=0.10 + , containers >=0.6 && <0.9 + , directory >=1.3.6 && <1.4 + , http-conduit ==2.* + , http-types >=0.11 && <0.13 + , ollama-haskell + , pdf-toolbox-document ==0.1.4 + , scalpel ==0.6.* + , text ==2.* + default-language: Haskell2010 + +test-suite langchain-hs-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Test.Langchain.Agent.Core + Test.Langchain.Agent.ReactAgent + Test.Langchain.DocumentLoader.Core + Test.Langchain.Embeddings.Core + Test.Langchain.LLM.Core + Test.Langchain.LLM.Ollama + Test.Langchain.Memory.Core + Test.Langchain.OutputParser.Core + Test.Langchain.PromptTemplate + Test.Langchain.Retriever.Core + Test.Langchain.Runnable.Chains + Test.Langchain.Runnable.ConversationChains + Test.Langchain.Runnable.Core + Test.Langchain.Runnable.Utils + Test.Langchain.TextSplitter.Character + Test.Langchain.Tool.Core + Test.Langchain.VectorStore.Core + 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.* + , base >=4.7 && <5 + , bytestring >=0.10 + , containers >=0.6 && <0.9 + , directory >=1.3.6 && <1.4 + , filepath + , http-conduit ==2.* + , http-types >=0.11 && <0.13 + , langchain-hs + , ollama-haskell + , pdf-toolbox-document ==0.1.4 + , scalpel ==0.6.* + , tasty + , tasty-hunit + , temporary + , text + default-language: Haskell2010 diff --git a/src/Langchain/Agents/Core.hs b/src/Langchain/Agents/Core.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Agents/Core.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module : Langchain.Agents.Core +Description : Core implementation of LangChain agents +Copyright : (c) 2025 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao + +Agents use LLMs as reasoning engines to determine actions dynamically +This module implements the core agent execution loop and interfaces, +supporting tool interaction and memory management. + +Example agent execution flow: + +> executor <- AgentExecutor +> { executor = myAgent +> , executorMemory = emptyMemory +> , maxIterations = 5 +> , returnIntermediateSteps = True +> } +> result <- runAgentExecutor executor "Explain quantum computing" +-} +module Langchain.Agents.Core + ( AgentAction (..) + , AgentFinish (..) + , AgentStep (..) + , Agent (..) + , AnyTool (..) + , AgentState (..) + , AgentExecutor (..) + , runAgent + , runAgentLoop + , runAgentExecutor + , executeTool + , runSingleStep + , customAnyTool + ) where + +import Control.Exception (SomeException, try) +import Data.List (find) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import Langchain.LLM.Core (Message (Message), Role (..), defaultMessageData) +import Langchain.Memory.Core (BaseMemory (..)) +import Langchain.PromptTemplate (PromptTemplate) +import qualified Langchain.Runnable.Core as Run +import Langchain.Tool.Core (Tool (..)) + +{- | +Represents an action to be taken by the agent +-} +data AgentAction = AgentAction + { actionToolName :: Text + -- ^ Tool name + , actionInput :: Text + -- ^ Input + , actionLog :: Text + -- ^ Execution log + } + deriving (Eq, Show) + +-- | Represents that agent has finished work with final value +data AgentFinish = AgentFinish + { returnValues :: Map.Map Text Text + , finishLog :: Text + } + deriving (Show, Eq) + +-- | Type that will be return from LLM +-- Could be either Continue, making another call to LLM or Finish with final value +data AgentStep + = Continue AgentAction + | Finish AgentFinish + deriving (Eq, Show) + +-- | Type for maintaining state of the agent +data (BaseMemory m) => AgentState m = AgentState + { agentMemory :: m -- ^ Memory for storing chat history + , agentToolResults :: [(Text, Text)] -- ^ Tool results + , agentSteps :: [AgentAction] -- ^ Agent steps happened so far + } + deriving (Eq, Show) + +{- | +Dynamic tool wrapper allowing heterogeneous tool collections +Converts between Text and tool-specific input/output types. + +Example usage: + +> calculatorTool :: AnyTool +> calculatorTool = customAnyTool +> Calculator +> (\t -> read (T.unpack t) :: (Int, Int)) +> (T.pack . show) +-} +data AnyTool = forall a. Tool a => AnyTool + { anyTool :: a + , textToInput :: Text -> Input a + , outputToText :: Output a -> Text + } + +{- | +Core agent class defining required operations + +* Plan next action based on state +* Provide prompt template +* Expose available tools +-} +class Agent a where + planNextAction :: BaseMemory m => a -> AgentState m -> IO (Either String AgentStep) + agentPrompt :: a -> IO PromptTemplate + agentTools :: a -> IO [AnyTool] + +{- | +Agent execution engine +-} +data AgentExecutor a m = AgentExecutor + { executor :: a -- Agent instance + , executorMemory :: m + -- ^ Memory state + , maxIterations :: Int + -- ^ Iteration limits + , returnIntermediateSteps :: Bool + -- ^ Step tracking + } + deriving (Eq, Show) + +{- | +Run the full agent execution loop +Handles: + +1. Memory updates +2. Action planning +3. Tool execution +4. Iteration control + +Example flow: + +1. User input -> memory +2. Plan action -> execute tool +3. Store result -> memory +4. Repeat until finish + +Throws errors for: + +- Tool not found [[5]] +- Execution errors +- Iteration limits +-} +runAgent :: (Agent a, BaseMemory m) => a -> AgentState m -> Text -> IO (Either String AgentFinish) +runAgent agent initialState@AgentState {..} initialInput = do + memWithInput <- addUserMessage agentMemory initialInput + case memWithInput of + Left err -> return $ Left err + Right updatedMem -> + let newState = initialState {agentMemory = updatedMem} + in runAgentLoop agent newState 0 10 + +-- | Helper function for runAgent +runAgentLoop :: + (Agent a, BaseMemory m) => a -> AgentState m -> Int -> Int -> IO (Either String AgentFinish) +runAgentLoop agent agentState@AgentState {..} currIter maxIter + | currIter > maxIter = return $ Left "Max iterations excedded" + | otherwise = do + eStepResult <- runSingleStep agent agentState + case eStepResult of + Left err -> return $ Left err + Right (Finish agentFinish) -> return $ Right agentFinish + Right (Continue act@AgentAction {..}) -> do + toolList <- agentTools agent + toolResult <- executeTool toolList actionToolName actionInput + case toolResult of + Left err -> return $ Left err + Right result -> do + -- Add the tool result to memory as a tool message + let toolMsg = Message Tool result defaultMessageData + updatedMemResult <- addMessage agentMemory toolMsg + case updatedMemResult of + Left err -> return $ Left err + Right updatedMem -> + let updatedState = + agentState + { agentMemory = updatedMem + , agentToolResults = agentToolResults ++ [(actionToolName, result)] + , agentSteps = agentSteps ++ [act] + } + in runAgentLoop agent updatedState (currIter + 1) maxIter + +-- | Alias for planNextAction +runSingleStep :: (Agent a, BaseMemory m) => a -> AgentState m -> IO (Either String AgentStep) +runSingleStep = planNextAction + +{- | +Execute a single tool call +Handles tool lookup and input/output conversion. + +Example: + +> tools = [calculatorTool, wikipediaTool] +> executeTool tools "calculator" "(5, 3)" +> -- Returns Right "8" +-} +executeTool :: [AnyTool] -> Text -> Text -> IO (Either String Text) +executeTool tools toolName_ input = + case find (\(AnyTool t _ _) -> toolName t == toolName_) tools of + Nothing -> return $ Left $ "Tool not found: " <> T.unpack toolName_ + Just (AnyTool {..}) -> do + resultE <- try $ do + let typedInput = textToInput input + result <- runTool anyTool typedInput + return $ outputToText result + case resultE of + Left ex -> return $ Left $ "Tool execution error: " <> show (ex :: SomeException) + Right output -> return $ Right output + +{- | +Helper for creating custom tool wrappers +Requires conversion functions between Text and tool-specific types. + +Example: + +> weatherTool = customAnyTool +> WeatherAPI +> parseLocation +> formatWeatherResponse +-} +customAnyTool :: Tool a => a -> (Text -> Input a) -> (Output a -> Text) -> AnyTool +customAnyTool tool inputConv outputConv = AnyTool tool inputConv outputConv + +-- | Similar to runAgent, but for AgentExecutor +runAgentExecutor :: + (Agent a, BaseMemory m) => AgentExecutor a m -> Text -> IO (Either String (Maybe AgentFinish)) +runAgentExecutor AgentExecutor {..} input = do + let initialState = + AgentState + { agentMemory = executorMemory + , agentToolResults = [] + , agentSteps = [] + } + result <- runAgent executor initialState input + case result of + Left err -> return $ Left err + Right a -> + if returnIntermediateSteps + then return $ Right $ Just a + else return $ Right Nothing + +{- | +Runnable instance for agent execution +Allows integration with LangChain workflows. + +Example: + +> response <- invoke myAgentExecutor "Solve 5+3" +> case response of +> Right result -> print result +> Left err -> print err +-} +instance (Agent a, BaseMemory m) => Run.Runnable (AgentExecutor a m) where + type RunnableInput (AgentExecutor a m) = Text + type RunnableOutput (AgentExecutor a m) = AgentFinish + + invoke AgentExecutor {..} input = do + let initialState = + AgentState + { agentMemory = executorMemory + , agentToolResults = [] + , agentSteps = [] + } + runAgent executor initialState input diff --git a/src/Langchain/Agents/React.hs b/src/Langchain/Agents/React.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Agents/React.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.Agents.React +Description : Implementation of ReAct agent combining reasoning and action +Copyright : (c) 2025 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao + +Implements the ReAct pattern where the agent alternates between: + +1. Reasoning (generating thoughts) +2. Acting (executing tools) + +Example agent interaction: + +> agent <- createReactAgent llm [wikipediaTool, calculatorTool] +> result <- runAgentExecutor executor "What's the population of Paris?" +> -- Agent might: +> -- 1. Use Wikipedia tool to find current population data +> -- 2. Use calculator tool to verify numbers +> -- 3. Return final answer +-} +module Langchain.Agents.React + ( ReactAgentOutputParser (..) + , parseReactOutput + , ReactAgent (..) + , createReactAgent + , formatToolDescriptions + , formatToolNames + , getLastUserInput + ) where + +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import Langchain.Agents.Core +import Langchain.LLM.Core +import Langchain.Memory.Core +import Langchain.OutputParser.Core +import Langchain.PromptTemplate +import Langchain.Tool.Core + +{- | +Output parser for ReAct agent responses +Handles two primary formats: + +1. Final answers containing "Final Answer:" +2. Action requests with "Action:" and "Action Input:" + +Example parsing: + +> parseReactOutput "Final Answer: 42" +> -- Right (Finish ...) +> +> parseReactOutput "Action: calculator\nAction Input: 5+3" +> -- Right (Continue ...) +-} +newtype ReactAgentOutputParser = ReactAgentOutputParser AgentStep + +instance OutputParser ReactAgentOutputParser where + parse = parseReactOutput + +-- | Parses the output from a React agent +parseReactOutput :: Text -> Either String ReactAgentOutputParser +parseReactOutput text + | T.isInfixOf "Final Answer:" text = + -- Extract the final answer + let answer = extractAfter "Final Answer:" text + in Right $ + ReactAgentOutputParser $ + Finish $ + AgentFinish + { returnValues = Map.singleton "output" answer + , finishLog = text + } + | T.isInfixOf "Action:" text && T.isInfixOf "Action Input:" text = + -- Extract action and action input + let actionName = extractAfter "Action:" $ T.takeWhile (/= '\n') $ T.dropWhile (/= 'A') text + actionInput_ = + extractAfter "Action Input:" $ T.takeWhile (/= '\n') $ snd $ T.breakOn "Action Input:" text + in Right $ + ReactAgentOutputParser $ + Continue $ + AgentAction + { actionToolName = T.strip actionName + , actionInput = T.strip actionInput_ + , actionLog = text + } + | otherwise = Left $ "Could not parse agent output: " <> T.unpack text + +{- | +Core ReAct agent configuration. +Contains: + +- LLM for reasoning +- Available tools +- Prompt template for interaction + +Example creation: + +> agent <- createReactAgent +> openAIGPT +> [ AnyTool wikipediaTool +> , AnyTool calculatorTool +> ] +-} +data (LLM llm) => ReactAgent llm = ReactAgent + { reactLLM :: llm + , reactTools :: [AnyTool] + , reactPromptTemplate :: PromptTemplate + } + +-- Helper function to extract text after a marker +extractAfter :: Text -> Text -> Text +extractAfter marker text = + let afterMarker = snd $ T.breakOn marker text + in if T.null afterMarker + then "" + else T.strip $ T.dropWhile (/= ':') afterMarker + +{- | +Creates a ReAct agent with standard prompt structure +The prompt instructs the LLM to: + +1. List available tools +2. Follow thought-action-observation pattern +3. Provide final answers + +Example prompt excerpt: + +> "Use the following format: +> Thought: ... +> Action: [tool_name] +> Action Input: ..." +-} +createReactAgent :: + (LLM llm) => + llm -> + [AnyTool] -> + IO (Either String (ReactAgent llm)) +createReactAgent llm tools = do + let reactPrompt = + PromptTemplate $ + T.unlines + [ "You are an AI assistant designed to help with tasks." + , "You have access to the following tools:" + , "{tools_description}" + , "" + , "Use the following format:" + , "" + , "Thought: you should always think about what to do" + , "Action: the action to take, should be one of [{tool_names}]" + , "Action Input: the input to the action" + , "Observation: the result of the action" + , "... (this Thought/Action/Action Input/Observation can repeat N times)" + , "Thought: I now know the final answer" + , "Final Answer: the final answer to the original input question" + ] + return $ + Right $ + ReactAgent + { reactLLM = llm + , reactTools = tools + , reactPromptTemplate = reactPrompt + } + +instance (LLM llm) => Agent (ReactAgent llm) where + -- \| + -- Core reasoning loop implementing ReAct pattern + -- + -- 1. Retrieve chat history + -- 2. Format tool information + -- 3. Construct reasoning prompt + -- 4. Execute LLM call + -- 5. Parse response into action/answer + -- + -- Uses depth-first planning with backtracking + -- + planNextAction ReactAgent {..} state = do + let mem = agentMemory state + msgResult <- messages mem + case msgResult of + Left err -> return $ Left err + Right msgs -> do + -- Format the tools descriptions + let toolDescs = formatToolDescriptions reactTools + userQuery = getLastUserInput msgs + -- Build the prompt variables + let promptVars = + Map.fromList + [ ("tools_description", toolDescs) + , ("tool_names", formatToolNames reactTools) + ] + + -- Render the prompt + case renderPrompt reactPromptTemplate promptVars of + Left err -> return $ Left err + Right renderedPrompt -> do + -- Call the LLM + let m = + ( msgs + `NE.append` NE.fromList + [ (Message System renderedPrompt defaultMessageData) + , (Message User userQuery defaultMessageData) + ] + ) + response <- + chat + reactLLM + m + Nothing + case response of + Left err -> return $ Left err + Right llmOutput -> do + -- Parse the output + case parse llmOutput of + Left err -> return $ Left $ "Failed to parse LLM output: " <> err + Right (ReactAgentOutputParser step) -> return $ Right step + + agentPrompt ReactAgent {..} = pure reactPromptTemplate + agentTools ReactAgent {..} = pure reactTools + +{- | +Formats tool descriptions for LLM consumption +Creates a list like: + +> "Tool: wikipedia +> Description: Search Wikipedia..." +-} +formatToolDescriptions :: [AnyTool] -> Text +formatToolDescriptions tools = T.intercalate "\n\n" $ map formatTool tools + where + formatTool (AnyTool tool _ _) = + T.concat ["Tool: ", toolName tool, "\nDescription: ", toolDescription tool] + +{- | +Creates comma-separated tool names for prompt inclusion +Example output: "wikipedia, calculator, weather" +-} +formatToolNames :: [AnyTool] -> Text +formatToolNames tools = T.intercalate ", " $ map (\(AnyTool tool _ _) -> toolName tool) tools + +{- | +Extracts latest user query from chat history +Handles cases where: + +- Multiple user messages exist +- No user input found +-} +getLastUserInput :: ChatMessage -> Text +getLastUserInput msgs = + let userMsgs = filter (\m -> role m == User) $ NE.toList msgs + in if null userMsgs + then "" + else content $ last userMsgs diff --git a/src/Langchain/Callback.hs b/src/Langchain/Callback.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Callback.hs @@ -0,0 +1,87 @@ +{- | +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/DocumentLoader/Core.hs b/src/Langchain/DocumentLoader/Core.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/DocumentLoader/Core.hs @@ -0,0 +1,139 @@ +{- | +Module : Langchain.DocumentLoader.Core +Description : Core document loading functionality for LangChain Haskell +Copyright : (c) 2025 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)]} +-} +module Langchain.DocumentLoader.Core + ( -- * Document Representation + Document (..) + + -- * Loading Interface + , BaseLoader (..) + ) where + +import Data.Aeson +import Data.Map (Map, empty) +import Data.Text (Text) + +{- | Document container with content and metadata. +Used for storing loaded data and associated metadata like source URLs or page numbers. + +Example: + +>>> Document "Hello World" (fromList [("source", String "example.txt")]) +Document {pageContent = "Hello World", metadata = fromList [("source",String "example.txt")]} +-} +data Document = Document + { pageContent :: Text + -- ^ The text content of the document + , metadata :: Map 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) +@ +-} +class BaseLoader m where + -- | Load all documents from the source. + load :: m -> IO (Either String [Document]) + + -- | Load all the document and split them using recursiveCharacterSpliter + loadAndSplit :: m -> IO (Either String [Text]) + +{- $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"] +-} + +-- TODO: Implement lazy versions of Document and load. +-- Lazily load documents from the source. +-- lazyLoad :: m -> IO (Either String [Document]) diff --git a/src/Langchain/DocumentLoader/FileLoader.hs b/src/Langchain/DocumentLoader/FileLoader.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/DocumentLoader/FileLoader.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Langchain.DocumentLoader.FileLoader +Description : File loading implementation for LangChain Haskell +Copyright : (c) 2025 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", ...] +@ +-} +module Langchain.DocumentLoader.FileLoader + ( FileLoader (..) + ) where + +import Data.Aeson +import Data.Map (fromList) +import Data.Text (pack) +import Langchain.DocumentLoader.Core +import Langchain.TextSplitter.Character +import System.Directory (doesFileExist) + +{- | File loader configuration +Specifies the file path to load documents from. + +Example: + +>>> FileLoader "docs/example.txt" +FileLoader "docs/example.txt" +-} +data FileLoader = FileLoader FilePath + +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 + if exists + then do + content <- readFile path + let meta = fromList [("source", String $ pack path)] + return $ Right [Document (pack content) meta] + else + return $ Left $ "File not found: " ++ path + + -- \| Load and split content using default character splitter + -- + -- Example: + + -- >>> loadAndSplit (FileLoader "split.txt") + -- Right ["Paragraph 1", "Paragraph 2", ...] + -- + loadAndSplit (FileLoader path) = do + exists <- doesFileExist path + if exists + then do + content <- readFile path + return $ Right $ splitText defaultCharacterSplitterOps (pack content) + else + return $ Left $ "File not found: " ++ path + +{- $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"] +-} diff --git a/src/Langchain/DocumentLoader/PdfLoader.hs b/src/Langchain/DocumentLoader/PdfLoader.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/DocumentLoader/PdfLoader.hs @@ -0,0 +1,110 @@ +{-# 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 PDF files by implementing the +'BaseLoader' interface from "Langchain.DocumentLoader.Core". It uses +the 'Pdf.Document' library to open a PDF and extract its content, turning +each page into a 'Document'. Additionally, it provides a method to load the +raw content of the file and split it using a recursive character splitter. +-} +module Langchain.DocumentLoader.PdfLoader + ( PdfLoader (..) + ) where + +import Data.Aeson +import Data.Map (fromList) +import Data.Text (pack) +import Langchain.DocumentLoader.Core +import Langchain.TextSplitter.Character +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 + $ map + ( \(content, pageNum) -> + Document + { pageContent = content + , metadata = fromList [("page number", Number $ fromIntegral pageNum)] + } + ) + $ zip 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. +-} +data 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 $ "File not found: " ++ path + + -- \| + -- Loads the raw content of the PDF file and splits it using a recursive character splitter. + -- + -- This method reads the entire file as text (without parsing its PDF structure) 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 + content <- readFile path + return $ Right $ splitText defaultCharacterSplitterOps (pack content) + else + return $ Left $ "File not found: " ++ path diff --git a/src/Langchain/Embeddings/Core.hs b/src/Langchain/Embeddings/Core.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Embeddings/Core.hs @@ -0,0 +1,101 @@ +{- | +Module : Langchain.Embeddings.Core +Description : Embedding model interface for LangChain Haskell +Copyright : (c) 2025 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: + +@ +-- Hypothetical HuggingFace embedding instance +data HuggingFaceEmbeddings = HuggingFaceEmbeddings + +instance Embeddings HuggingFaceEmbeddings where + embedDocuments _ docs = do + -- Convert documents to vectors using HuggingFace API + return $ Right [[0.1, 0.3, ...], ...] + + embedQuery _ query = do + -- Convert query to vector + return $ Right [0.2, 0.4, ...] + +-- Usage with loaded documents +docs <- load (FileLoader "data.txt") +case docs of + Right documents -> do + vectors <- embedDocuments HuggingFaceEmbeddings documents + -- Use vectors for semantic search + Left err -> print err +@ +-} +module Langchain.Embeddings.Core + ( -- * Embedding Interface + Embeddings (..) + ) where + +import Data.Text (Text) +import Langchain.DocumentLoader.Core + +{- | 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 + +instance Embeddings TestEmbeddings where + embedDocuments _ _ = return $ Right [[0.1, 0.2, 0.3]] + embedQuery _ _ = return $ Right [0.4, 0.5, 0.6] +@ +-} +class Embeddings m where + -- | Convert documents to embedding vectors + -- + -- Example: + -- + -- >>> let doc = Document "Hello world" mempty + -- >>> embedDocuments TestEmbeddings [doc] + -- Right [[0.1, 0.2, 0.3]] + embedDocuments :: m -> [Document] -> IO (Either String [[Float]]) + + -- | Convert query text to embedding vector + -- + -- Example: + -- + -- >>> embedQuery TestEmbeddings "Search query" + -- Right [0.4, 0.5, 0.6] + embedQuery :: m -> Text -> IO (Either String [Float]) + +{- $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] + +3. Error handling + >>> -- Simulate failed API call + >>> embedQuery FaultyEmbeddings "Bad request" + Left "API request failed" +-} diff --git a/src/Langchain/Embeddings/Ollama.hs b/src/Langchain/Embeddings/Ollama.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Embeddings/Ollama.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.Embeddings.Ollama +Description : Ollama integration for text embeddings in LangChain Haskell +Copyright : (c) 2025 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 = "llama3" + , 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, ...]] +@ +-} +module Langchain.Embeddings.Ollama + ( OllamaEmbeddings (..) + ) where + +import Data.Maybe +import Data.Ollama.Embeddings +import Data.Text (Text) +import Langchain.DocumentLoader.Core +import Langchain.Embeddings.Core + +{- | Ollama-specific embedding configuration +Contains parameters for controlling: + +- Model selection +- Input truncation behavior +- Model caching via keep-alive + +Example configuration: + +>>> OllamaEmbeddings "nomic-embed" (Just False) (Just "1h") +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 Text + -- ^ Keep model loaded for specified duration (e.g., "5m") + } + deriving (Show, Eq) + +go :: EmbeddingResp -> Either String [Float] +go embResp = + case listToMaybe (embedding_ embResp) of + Nothing -> Left "Embeddings are empty" + Just x -> Right x + +{- | Ollama implementation of the 'Embeddings' interface [[6]]. +Uses Ollama's embedding API for vector generation. Handles: +- Multiple document embedding via batch processing +- Query embedding for similarity searches +- Error propagation from API responses + +Example instance usage: +@ +-- Embed multiple documents +docs <- load (FileLoader "data.txt") +case docs of + Right documents -> do + vecs <- embedDocuments ollamaEmb documents + -- Use vectors for semantic search + Left err -> print err +@ +-} +instance Embeddings OllamaEmbeddings where + -- \| Document embedding implementation [[3]]: + -- 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 + results <- mapM (\doc -> embeddingOps model (pageContent doc) defaultTruncate defaultKeepAlive) docs + -- Combine the results, handling errors appropriately + return $ + sequence results >>= \resps -> + mapM go resps + + -- \| 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 + case fmap embedding_ res of + Left err -> pure $ Left err + Right lst -> + case listToMaybe lst of + Nothing -> pure $ Left "Embeddings are empty" + Just x -> pure $ Right x diff --git a/src/Langchain/LLM/Core.hs b/src/Langchain/LLM/Core.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/LLM/Core.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module: Langchain.LLM.Core +Copyright: (c) 2025 Tushar Adhatrao +License: MIT +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 'Params' for configuring model invocations, '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 (..) + , ChatMessage + , MessageData (..) + , Params (..) + , StreamHandler (..) + + -- * Default Values + , defaultParams + , defaultMessageData + ) where + +import Data.Aeson +import Data.List.NonEmpty +import Data.Text (Text) +import GHC.Generics + +{- | Parameters for configuring language model invocations. +These parameters control aspects such as randomness, length, and stopping conditions of generated output. +This type corresponds to standard parameters in Python Langchain: +https://python.langchain.com/docs/concepts/chat_models/#standard-parameters + +Example usage: + +@ +myParams :: Params +myParams = defaultParams + { temperature = Just 0.7 + , maxTokens = Just 100 + } +@ +-} +data Params = Params + { temperature :: Maybe Double + -- ^ Sampling temperature. Higher values increase randomness (creativity), while lower values make output more focused. + , maxTokens :: Maybe Integer + , --- ^ Maximum number of tokens to generate in the response. + topP :: Maybe Double + -- ^ Nucleus sampling parameter. Considers tokens whose cumulative probability mass is at least @topP@. + , n :: Maybe Int + -- ^ Number of responses to generate (e.g., for sampling multiple outputs). + , stop :: Maybe [Text] + -- ^ Sequences where generation should stop (e.g., ["\n"] stops at newlines). + } + deriving (Show, Eq) + +{- | 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 = StreamHandler + { onToken :: Text -> 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 + 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) + +{- | 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 [Text] + -- ^ Optional list of tool calls invoked by the message + } + deriving (Eq, Show) + +-- | JSON serialization for MessageData. +instance ToJSON MessageData where + toJSON MessageData {..} = + object + [ "name" .= name + , "tool_calls" .= toolCalls + -- 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" + +-- | Type alias for NonEmpty Message +type ChatMessage = NonEmpty Message + +{- | 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 + } + +{- | Typeclass defining the interface for language models. +This provides methods for invoking the model, chatting with it, and streaming +responses. + +@ +data TestLLM = TestLLM + { responseText :: Text + , shouldSucceed :: Bool + } + +instance LLM TestLLM where + generate m _ _ = pure $ if shouldSucceed m + then Right (responseText m) + else Left "Test error" +@ + + +@ +ollamaLLM = Ollama "llama3.2:latest" [stdOutCallback] +response <- generate ollamaLLM "What is Haskell?" Nothing +@ +-} +class LLM m where + -- | Invoke the language model with a single prompt. + -- Suitable for simple queries; returns either an error or generated text. + + {- === Using 'generate' + To invoke an LLM with a single prompt: + + @ + let myLLM = ... -- assume this is an instance of LLM + result <- generate myLLM "What is the meaning of life?" Nothing + case result of + Left err -> putStrLn $ "Error: " ++ err + Right response -> putStrLn response + @ + + -} + generate :: m -- ^ The type of the language model instance. + -> Text -- ^ The prompt to send to the model. + -> Maybe Params -- ^ Optional configuration parameters. + -> IO (Either String Text) + + -- | Chat with the language model using a sequence of messages. + -- Suitable for multi-turn conversations; returns either an error or the response. + -- + chat :: m -- ^ The type of the language model instance. + -> ChatMessage -- ^ A non-empty list of messages to send to the model. + -> Maybe Params -- ^ Optional configuration parameters. + -> IO (Either String Text) -- ^ The result of the chat, either an error or the response text. + + -- | 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 :: m -> ChatMessage -> StreamHandler -> Maybe Params -> IO (Either String ()) + +{- | Default parameters with all fields set to Nothing. +Use this when no specific configuration is needed for the language model. + +>>> generate myLLM "Hello" (Just defaultParams) +-} +defaultParams :: Params +defaultParams = + Params + { temperature = Nothing + , maxTokens = Nothing + , topP = Nothing + , n = Nothing + , stop = Nothing + } diff --git a/src/Langchain/LLM/Ollama.hs b/src/Langchain/LLM/Ollama.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/LLM/Ollama.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +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 "llama3" [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 (..)) where + +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Ollama.Chat as OllamaChat +import qualified Data.Ollama.Generate as OllamaGenerate +import Data.Text (Text) +import Langchain.Callback (Callback, Event (..)) +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 +Note: Params argument is currently ignored (see TODOs). + +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 + -- \| 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 _ = do + mapM_ (\cb -> cb LLMStart) cbs + eRes <- + OllamaGenerate.generate + OllamaGenerate.defaultGenerateOps + { OllamaGenerate.modelName = model + , OllamaGenerate.prompt = prompt + , OllamaGenerate.stream = Nothing + } + case eRes of + Left err -> do + mapM_ (\cb -> cb (LLMError err)) cbs + return $ Left (show err) + Right res -> do + mapM_ (\cb -> cb LLMEnd) cbs + return $ Right (OllamaGenerate.response_ res) + + -- \| 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 _ = do + mapM_ (\cb -> cb LLMStart) cbs + eRes <- + OllamaChat.chat + OllamaChat.defaultChatOps + { OllamaChat.chatModelName = model + , OllamaChat.messages = toOllamaMessages messages + , OllamaChat.stream = Nothing + } + case eRes of + Left err -> do + mapM_ (\cb -> cb (LLMError err)) cbs + return $ Left (show err) + Right res -> do + mapM_ (\cb -> cb LLMEnd) cbs + return $ Right (chatRespToText res) + where + chatRespToText resp = maybe "" OllamaChat.content (OllamaChat.message resp) + + -- \| 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 + -- + stream (Ollama model_ cbs) messages StreamHandler {onToken, onComplete} _ = do + mapM_ (\cb -> cb LLMStart) cbs + eRes <- + OllamaChat.chat + OllamaChat.defaultChatOps + { OllamaChat.chatModelName = model_ + , OllamaChat.messages = toOllamaMessages messages + , OllamaChat.stream = Just (onToken . chatRespToText, onComplete) + } + case eRes of + Left err -> do + mapM_ (\cb -> cb (LLMError err)) cbs + return $ Left (show err) + Right _ -> do + mapM_ (\cb -> cb LLMEnd) cbs + return $ Right () + where + chatRespToText OllamaChat.ChatResponse {..} = maybe "" OllamaChat.content message + +{- | Convert LangChain messages to Ollama format. +Current limitations: +- Ignores 'messageData' field +- No tool call support (see TODO) + +Example conversion: +>>> let msg = Message System "You are an assistant" defaultMessageData +>>> toOllamaMessages (msg :| []) +NonEmpty [OllamaChat.Message System "You are an assistant" Nothing Nothing] +-} +toOllamaMessages :: NonEmpty Message -> NonEmpty OllamaChat.Message +toOllamaMessages = NonEmpty.map $ \Message {..} -> + OllamaChat.Message (toOllamaRole role) content Nothing Nothing + where + toOllamaRole User = OllamaChat.User + toOllamaRole System = OllamaChat.System + toOllamaRole Assistant = OllamaChat.Assistant + toOllamaRole Tool = OllamaChat.Tool + +instance Run.Runnable Ollama where + type RunnableInput Ollama = ChatMessage + type RunnableOutput Ollama = Text + + -- TODO: need to figure out a way to pass mbParams + -- \| Runnable interface implementation. + -- Currently delegates to 'chat' method with default parameters. + -- + invoke model input = chat model input Nothing + +{- $examples +Test case patterns: +1. Basic generation + >>> generate (Ollama "test-model" []) "Hello" Nothing + Right "Mock response" + +2. Error handling + >>> generate (Ollama "invalid-model" []) "Test" Nothing + Left "API request failed" + +3. Streaming interaction + >>> let handler = StreamHandler print (pure ()) + >>> stream (Ollama "llama3" []) (UserMessage "Hi" :| []) handler Nothing + Right () +-} diff --git a/src/Langchain/LLM/OpenAI.hs b/src/Langchain/LLM/OpenAI.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/LLM/OpenAI.hs @@ -0,0 +1,870 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- This module is not tested since I don't have the OpenAI api key. + +{- | +Module : Langchain.LLM.OpenAI +Description : OpenAI integration for LangChain Haskell +Copyright : (c) 2025 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +OpenAI implementation of LangChain's LLM interface. Not tested +-} +module Langchain.LLM.OpenAI + ( OpenAI (..) + -- * Data Types + , ChatCompletionRequest (..) + , ChatCompletionResponse (..) + , Message (..) + , Role (..) + , MessageContent (..) + , TextContent (..) + , Tool_ (..) + , Function_ (..) + , ToolCall (..) + , FunctionCall_ (..) + , Usage (..) + , Choice (..) + , FinishReason (..) + , LogProbs (..) + , LogProbContent (..) + , TopLogProb (..) + , AudioConfig (..) + , AudioResponse (..) + , Modality (..) + , ToolChoice (..) + , SpecificToolChoice (..) + , ReasoningEffort (..) + , PredictionOutput (..) + , PredictionContent (..) + , ResponseFormat (..) + , StreamOptions (..) + , WebSearchOptions (..) + , UserLocation (..) + , ApproximateLocation (..) + , CompletionTokensDetails (..) + , PromptTokensDetails (..) + -- * Functions + , createChatCompletion + , defaultChatCompletionRequest + , defaultMessage + ) where + +import Data.Aeson +import qualified Data.List.NonEmpty as NE +import Data.Map (Map) +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import GHC.Generics +import Langchain.Callback (Callback) +import qualified Langchain.LLM.Core as LLM +import Network.HTTP.Simple +import Network.HTTP.Types.Status (statusCode) + +{- | Represents different roles in a conversation +User: Human user input +Assistant: AI-generated response +System: System-level instructions +Developer: Special role for developer messages +Tool: Tool interaction messages +Function: Function call messages +-} +data Role + = User + | Assistant + | System + | Developer + | Tool + | Function + deriving (Show, Eq, Generic) + +instance ToJSON Role where + toJSON User = String "user" + toJSON Assistant = String "assistant" + toJSON System = String "system" + toJSON Developer = String "developer" + toJSON Tool = String "tool" + toJSON Function = String "function" + +instance FromJSON Role where + parseJSON (String "user") = return User + parseJSON (String "assistant") = return Assistant + parseJSON (String "system") = return System + parseJSON (String "developer") = return Developer + parseJSON (String "tool") = return Tool + parseJSON (String "function") = return Function + parseJSON invalid = fail $ "Invalid role: " ++ show invalid + +data TextContent = TextContent + { text_ :: Text + , contentType :: Text + } + deriving (Show, Eq, Generic) + +instance ToJSON TextContent where + toJSON TextContent {..} = + object + [ "text" .= text_ + , "type" .= contentType + ] + +instance FromJSON TextContent where + parseJSON = withObject "TextContent" $ \v -> + TextContent + <$> v .: "text" + <*> v .: "type" + +data MessageContent + = StringContent Text + | ContentParts [TextContent] + deriving (Show, Eq, Generic) + +instance ToJSON MessageContent where + toJSON (StringContent text) = String text + toJSON (ContentParts parts) = toJSON parts + +instance FromJSON MessageContent where + parseJSON (String s) = return $ StringContent s + parseJSON (Array arr) = ContentParts <$> parseJSON (Array arr) + parseJSON invalid = fail $ "Invalid message content: " ++ show invalid + +data Function_ = Function_ + { name :: Text + , description :: Maybe Text + , parameters :: Maybe Value + , strict :: Maybe Bool + } + deriving (Show, Eq, Generic) + +instance ToJSON Function_ where + toJSON Function_ {..} = + object $ + [ "name" .= name + ] + ++ maybe [] (\d -> ["description" .= d]) description + ++ maybe [] (\p -> ["parameters" .= p]) parameters + ++ maybe [] (\s -> ["strict" .= s]) strict + +instance FromJSON Function_ where + parseJSON = withObject "Function" $ \v -> + Function_ + <$> v .: "name" + <*> v .:? "description" + <*> v .:? "parameters" + <*> v .:? "strict" + +data Tool_ = Tool_ + { toolType :: Text + , function :: Function_ + } + 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" + +data FunctionCall_ = FunctionCall_ + { name :: Text + , arguments :: Text + } + deriving (Show, Eq, Generic) + +instance ToJSON FunctionCall_ where + toJSON FunctionCall_ {..} = + object + [ "name" .= name + , "arguments" .= arguments + ] + +instance FromJSON FunctionCall_ where + parseJSON = withObject "FunctionCall" $ \v -> + FunctionCall_ + <$> v .: "name" + <*> v .: "arguments" + +data ToolCall = ToolCall + { id_ :: Text + , toolType :: Text + , function :: FunctionCall_ + } + deriving (Show, Eq, Generic) + +instance ToJSON ToolCall where + toJSON ToolCall {..} = + object + [ "id" .= id_ + , "type" .= toolType + , "function" .= function + ] + +instance FromJSON ToolCall where + parseJSON = withObject "ToolCall" $ \v -> + ToolCall + <$> v .: "id" + <*> v .: "type" + <*> v .: "function" + +{- | Configuration for audio processing +Specifies format and voice preferences for text-to-speech +-} +data AudioConfig = AudioConfig + { format :: Text + , voice :: Text + } + deriving (Show, Eq, Generic) + +instance ToJSON AudioConfig where + toJSON AudioConfig {..} = + object + [ "format" .= format + , "voice" .= voice + ] + +instance FromJSON AudioConfig where + parseJSON = withObject "AudioConfig" $ \v -> + AudioConfig + <$> v .: "format" + <*> v .: "voice" + +data AudioResponse = AudioResponse + { data_ :: Text + , expiresAt :: Integer + , id_ :: Text + , transcript :: Text + } + deriving (Show, Eq, Generic) + +instance ToJSON AudioResponse where + toJSON AudioResponse {..} = + object + [ "data" .= data_ + , "expires_at" .= expiresAt + , "id" .= id_ + , "transcript" .= transcript + ] + +instance FromJSON AudioResponse where + parseJSON = withObject "AudioResponse" $ \v -> + AudioResponse + <$> v .: "data" + <*> v .: "expires_at" + <*> v .: "id" + <*> v .: "transcript" + +{- | Represents a single message in a conversation +Contains role, content, and optional metadata like function calls or audio responses. +-} +data Message = Message + { role :: Role + , content :: Maybe MessageContent + , name :: Maybe Text + , functionCall :: Maybe FunctionCall_ + , toolCalls :: Maybe [ToolCall] + , toolCallId :: Maybe Text + , audio :: Maybe AudioResponse + , refusal :: Maybe Text + } + deriving (Show, Eq, Generic) + +defaultMessage :: Message +defaultMessage = + Message + { role = User + , content = Nothing + , name = Nothing + , functionCall = Nothing + , toolCalls = Nothing + , toolCallId = Nothing + , audio = Nothing + , refusal = Nothing + } + +instance ToJSON Message where + toJSON Message {..} = + object $ + ["role" .= role] + ++ maybe [] (\c -> ["content" .= c]) content + ++ maybe [] (\n -> ["name" .= n]) name + ++ maybe [] (\fc -> ["function_call" .= fc]) functionCall + ++ maybe [] (\tc -> ["tool_calls" .= tc]) toolCalls + ++ maybe [] (\tcid -> ["tool_call_id" .= tcid]) toolCallId + ++ maybe [] (\a -> ["audio" .= a]) audio + ++ maybe [] (\r -> ["refusal" .= r]) refusal + +instance FromJSON Message where + parseJSON = withObject "Message" $ \v -> + Message + <$> v .: "role" + <*> v .:? "content" + <*> v .:? "name" + <*> v .:? "function_call" + <*> v .:? "tool_calls" + <*> v .:? "tool_call_id" + <*> v .:? "audio" + <*> v .:? "refusal" + +data Modality = TextModality | AudioModality + deriving (Show, Eq, Generic) + +instance ToJSON Modality where + toJSON TextModality = String "text" + toJSON AudioModality = String "audio" + +instance FromJSON Modality where + parseJSON (String "text") = return TextModality + parseJSON (String "audio") = return AudioModality + parseJSON invalid = fail $ "Invalid modality: " ++ show invalid + +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 + +data SpecificToolChoice = SpecificToolChoice + { toolType :: Text + , function :: Value + } + deriving (Show, Eq, Generic) + +instance ToJSON SpecificToolChoice where + toJSON SpecificToolChoice {..} = + object + [ "type" .= toolType + , "function" .= function + ] + +instance FromJSON SpecificToolChoice where + parseJSON = withObject "SpecificToolChoice" $ \v -> + SpecificToolChoice + <$> v .: "type" + <*> v .: "function" + +data ReasoningEffort = Low | Medium | High + deriving (Show, Eq, Generic) + +instance ToJSON ReasoningEffort where + toJSON Low = String "low" + toJSON Medium = String "medium" + toJSON High = String "high" + +instance FromJSON ReasoningEffort where + parseJSON (String "low") = return Low + parseJSON (String "medium") = return Medium + parseJSON (String "high") = return High + parseJSON invalid = fail $ "Invalid reasoning effort: " ++ show invalid + +data PredictionContent = PredictionContent + { content :: MessageContent + , contentType :: Text + } + deriving (Show, Eq, Generic) + +instance ToJSON PredictionContent where + toJSON PredictionContent {..} = + object + [ "content" .= content + , "type" .= contentType + ] + +instance FromJSON PredictionContent where + parseJSON = withObject "PredictionContent" $ \v -> + PredictionContent + <$> v .: "content" + <*> v .: "type" + +data PredictionOutput = PredictionOutput + { predictionType :: Text + , content :: MessageContent + } + deriving (Show, Eq, Generic) + +instance ToJSON PredictionOutput where + toJSON PredictionOutput {..} = + object + [ "type" .= predictionType + , "content" .= content + ] + +instance FromJSON PredictionOutput where + parseJSON = withObject "PredictionOutput" $ \v -> + PredictionOutput + <$> v .: "type" + <*> v .: "content" + +data ResponseFormat = JsonObjectFormat | JsonSchemaFormat Value + deriving (Show, Eq, Generic) + +instance ToJSON ResponseFormat where + toJSON JsonObjectFormat = object ["type" .= ("json_object" :: Text)] + toJSON (JsonSchemaFormat schema) = + object + [ "type" .= ("json_schema" :: Text) + , "json_schema" .= schema + ] + +instance FromJSON ResponseFormat where + parseJSON = withObject "ResponseFormat" $ \v -> do + formatType <- v .: "type" + case formatType of + String "json_object" -> return JsonObjectFormat + String "json_schema" -> JsonSchemaFormat <$> v .: "json_schema" + _ -> fail $ "Invalid response format type: " ++ show formatType + +data StreamOptions = StreamOptions + { includeUsage :: Bool + } + deriving (Show, Eq, Generic) + +instance ToJSON StreamOptions where + toJSON StreamOptions {..} = + object + [ "include_usage" .= includeUsage + ] + +instance FromJSON StreamOptions where + parseJSON = withObject "StreamOptions" $ \v -> + StreamOptions <$> v .: "include_usage" + +data ApproximateLocation = ApproximateLocation + { locationType :: Text + } + deriving (Show, Eq, Generic) + +instance ToJSON ApproximateLocation where + toJSON ApproximateLocation {..} = + object + [ "type" .= locationType + ] + +instance FromJSON ApproximateLocation where + parseJSON = withObject "ApproximateLocation" $ \v -> + ApproximateLocation <$> v .: "type" + +data UserLocation = UserLocation + { approximate :: ApproximateLocation + } + deriving (Show, Eq, Generic) + +instance ToJSON UserLocation where + toJSON UserLocation {..} = + object + [ "approximate" .= approximate + ] + +instance FromJSON UserLocation where + parseJSON = withObject "UserLocation" $ \v -> + UserLocation <$> v .: "approximate" + +data WebSearchOptions = WebSearchOptions + { searchContextSize :: Maybe Text + , userLocation :: Maybe UserLocation + } + deriving (Show, Eq, Generic) + +instance ToJSON WebSearchOptions where + toJSON WebSearchOptions {..} = + object $ + maybe [] (\s -> ["search_context_size" .= s]) searchContextSize + ++ maybe [] (\l -> ["user_location" .= l]) userLocation + +instance FromJSON WebSearchOptions where + parseJSON = withObject "WebSearchOptions" $ \v -> + WebSearchOptions + <$> v .:? "search_context_size" + <*> v .:? "user_location" + +{- | Main request type for chat completions +Contains all parameters for configuring the OpenAI chat completion API call. +-} +data ChatCompletionRequest = ChatCompletionRequest + { messages :: [Message] + , model :: Text + , frequencyPenalty :: Maybe Double + , logitBias :: Maybe (Map Text Double) + , logprobs :: Maybe Bool + , maxCompletionTokens :: Maybe Int + , maxTokens :: Maybe Int + , metadata :: Maybe (Map Text Text) + , modalities :: Maybe [Modality] + , n :: Maybe Int + , parallelToolCalls :: Maybe Bool + , prediction :: Maybe PredictionOutput + , presencePenalty :: Maybe Double + , reasoningEffort :: Maybe ReasoningEffort + , responseFormat :: Maybe ResponseFormat + , seed :: Maybe Int + , serviceTier :: Maybe Text + , stop :: Maybe (Either Text [Text]) + , store :: Maybe Bool + , stream :: Maybe Bool + , streamOptions :: Maybe StreamOptions + , temperature :: Maybe Double + , toolChoice :: Maybe ToolChoice + , tools :: Maybe [Tool_] + , topLogprobs :: Maybe Int + , topP :: Maybe Double + , user :: Maybe Text + , webSearchOptions :: Maybe WebSearchOptions + , audio :: Maybe AudioConfig + } + deriving (Show, Eq, Generic) + +instance ToJSON ChatCompletionRequest where + toJSON ChatCompletionRequest {..} = + object $ + [ "messages" .= messages + , "model" .= model + ] + ++ maybe [] (\fp -> ["frequency_penalty" .= fp]) frequencyPenalty + ++ maybe [] (\lb -> ["logit_bias" .= lb]) logitBias + ++ maybe [] (\lp -> ["logprobs" .= lp]) logprobs + ++ maybe [] (\mt -> ["max_completion_tokens" .= mt]) maxCompletionTokens + ++ maybe [] (\mt -> ["max_tokens" .= mt]) maxTokens + ++ maybe [] (\md -> ["metadata" .= md]) metadata + ++ maybe [] (\m -> ["modalities" .= m]) modalities + ++ maybe [] (\n' -> ["n" .= n']) n + ++ maybe [] (\ptc -> ["parallel_tool_calls" .= ptc]) parallelToolCalls + ++ maybe [] (\p -> ["prediction" .= p]) prediction + ++ maybe [] (\pp -> ["presence_penalty" .= pp]) presencePenalty + ++ maybe [] (\re -> ["reasoning_effort" .= re]) reasoningEffort + ++ maybe [] (\rf -> ["response_format" .= rf]) responseFormat + ++ maybe [] (\s -> ["seed" .= s]) seed + ++ maybe [] (\st -> ["service_tier" .= st]) serviceTier + ++ maybe [] (\s -> ["stop" .= s]) stop + ++ maybe [] (\s -> ["store" .= s]) store + ++ maybe [] (\s -> ["stream" .= s]) stream + ++ maybe [] (\so -> ["stream_options" .= so]) streamOptions + ++ maybe [] (\t -> ["temperature" .= t]) temperature + ++ maybe [] (\tc -> ["tool_choice" .= tc]) toolChoice + ++ maybe [] (\t -> ["tools" .= t]) tools + ++ maybe [] (\tlp -> ["top_logprobs" .= tlp]) topLogprobs + ++ maybe [] (\tp -> ["top_p" .= tp]) topP + ++ maybe [] (\u -> ["user" .= u]) user + ++ maybe [] (\wso -> ["web_search_options" .= wso]) webSearchOptions + ++ maybe [] (\a -> ["audio" .= a]) audio + +-- Response Types +data FinishReason = Stop | Length | ContentFilter | ToolCalls | FunctionCall + deriving (Show, Eq, Generic) + +instance FromJSON FinishReason where + parseJSON (String "stop") = return Stop + parseJSON (String "length") = return Length + parseJSON (String "content_filter") = return ContentFilter + parseJSON (String "tool_calls") = return ToolCalls + parseJSON (String "function_call") = return FunctionCall + parseJSON invalid = fail $ "Invalid finish reason: " ++ show invalid + +data TopLogProb = TopLogProb + { bytes :: Maybe [Int] + , logprob :: Double + , token :: Text + } + deriving (Show, Eq, Generic) + +instance FromJSON TopLogProb where + parseJSON = withObject "TopLogProb" $ \v -> + TopLogProb + <$> v .:? "bytes" + <*> v .: "logprob" + <*> v .: "token" + +data LogProbContent = LogProbContent + { bytes :: Maybe [Int] + , logprob :: Double + , token :: Text + , topLogprobs :: [TopLogProb] + } + deriving (Show, Eq, Generic) + +instance FromJSON LogProbContent where + parseJSON = withObject "LogProbContent" $ \v -> + LogProbContent + <$> v .:? "bytes" + <*> v .: "logprob" + <*> v .: "token" + <*> v .: "top_logprobs" + +data LogProbs = LogProbs + { content :: Maybe [LogProbContent] + , refusal :: Maybe [LogProbContent] + } + deriving (Show, Eq, Generic) + +instance FromJSON LogProbs where + parseJSON = withObject "LogProbs" $ \v -> + LogProbs + <$> v .:? "content" + <*> v .:? "refusal" + +data CompletionTokensDetails = CompletionTokensDetails + { acceptedPredictionTokens :: Int + , audioTokens :: Int + , reasoningTokens :: Int + , rejectedPredictionTokens :: Int + } + deriving (Show, Eq, Generic) + +instance FromJSON CompletionTokensDetails where + parseJSON = withObject "CompletionTokensDetails" $ \v -> + CompletionTokensDetails + <$> v .: "accepted_prediction_tokens" + <*> v .: "audio_tokens" + <*> v .: "reasoning_tokens" + <*> v .: "rejected_prediction_tokens" + +data PromptTokensDetails = PromptTokensDetails + { audioTokens :: Int + , cachedTokens :: Int + } + deriving (Show, Eq, Generic) + +instance FromJSON PromptTokensDetails where + parseJSON = withObject "PromptTokensDetails" $ \v -> + PromptTokensDetails + <$> v .: "audio_tokens" + <*> v .: "cached_tokens" + +data Usage = Usage + { completionTokens :: Int + , promptTokens :: Int + , totalTokens :: Int + , completionTokensDetails :: Maybe CompletionTokensDetails + , promptTokensDetails :: Maybe PromptTokensDetails + } + deriving (Show, Eq, Generic) + +instance FromJSON Usage where + parseJSON = withObject "Usage" $ \v -> + Usage + <$> v .: "completion_tokens" + <*> v .: "prompt_tokens" + <*> v .: "total_tokens" + <*> v .:? "completion_tokens_details" + <*> v .:? "prompt_tokens_details" + +data Choice = Choice + { finishReason :: FinishReason + , index :: Int + , logprobs :: Maybe LogProbs + , message :: Message + } + deriving (Show, Eq, Generic) + +instance FromJSON Choice where + parseJSON = withObject "Choice" $ \v -> + Choice + <$> v .: "finish_reason" + <*> v .: "index" + <*> v .:? "logprobs" + <*> v .: "message" + +data ChatCompletionResponse = ChatCompletionResponse + { choices :: [Choice] + , created :: Integer + , id_ :: Text + , responseModel :: Text + , object_ :: Text + , serviceTier :: Maybe Text + , systemFingerprint :: Text + , usage :: Usage + } + deriving (Show, Eq, Generic) + +instance FromJSON ChatCompletionResponse where + parseJSON = withObject "ChatCompletionResponse" $ \v -> + ChatCompletionResponse + <$> v .: "choices" + <*> v .: "created" + <*> v .: "id" + <*> v .: "model" + <*> v .: "object" + <*> v .:? "service_tier" + <*> v .: "system_fingerprint" + <*> v .: "usage" + +{- | Default chat completion request +Uses "gpt-4o-mini-2024-07-18" as the default model. All other parameters are set to Nothing. +-} +defaultChatCompletionRequest :: ChatCompletionRequest +defaultChatCompletionRequest = + ChatCompletionRequest + { messages = [] + , model = "gpt-4o-mini-2024-07-18" + , frequencyPenalty = Nothing + , logitBias = Nothing + , logprobs = Nothing + , maxCompletionTokens = Nothing + , maxTokens = Nothing + , metadata = Nothing + , modalities = Nothing + , n = Nothing + , parallelToolCalls = Nothing + , prediction = Nothing + , presencePenalty = Nothing + , reasoningEffort = Nothing + , responseFormat = Nothing + , seed = Nothing + , serviceTier = Nothing + , stop = Nothing + , store = Nothing + , stream = Nothing + , streamOptions = Nothing + , temperature = Nothing + , toolChoice = Nothing + , tools = Nothing + , topLogprobs = Nothing + , topP = Nothing + , user = Nothing + , webSearchOptions = Nothing + , audio = Nothing + } + +{- | Creates a chat completion request +Sends the request to OpenAI API and returns the parsed response. + +Example usage: +@ +response <- createChatCompletion "your-api-key" request +case response of + Right res -> print (choices res) + Left err -> putStrLn err +@ +-} +createChatCompletion :: Text -> ChatCompletionRequest -> IO (Either String ChatCompletionResponse) +createChatCompletion apiKey r = do + request_ <- parseRequest "https://api.openai.com/v1/chat/completions" + let req = + setRequestMethod "POST" $ + setRequestSecure True $ + setRequestHost "api.openai.com" $ + setRequestPath "/v1/chat/completions" $ + setRequestHeader "Content-Type" ["application/json"] $ + setRequestHeader "Authorization" ["Bearer " <> encodeUtf8 apiKey] $ + setRequestBodyJSON r $ + request_ + + response <- httpLBS req + 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) + +data OpenAI = OpenAI + { apiKey :: Text + , openAIModelName :: Text + , callbacks :: [Callback] + } + +instance Show OpenAI where + show OpenAI {..} = "OpenAI " ++ show openAIModelName + +instance LLM.LLM OpenAI where + generate OpenAI {..} prompt _ = do + eRes <- + createChatCompletion + apiKey + ( defaultChatCompletionRequest + { model = openAIModelName + , messages = + [ Message + { role = User + , content = Just (StringContent prompt) + , name = Nothing + , functionCall = Nothing + , toolCalls = Nothing + , toolCallId = Nothing + , audio = Nothing + , refusal = Nothing + } + ] + } + ) + case eRes of + Left err -> return $ Left err + Right r -> do + case listToMaybe (choices r) of + Nothing -> return $ Left "Did not received any response" + Just resp -> + let Message {..} = message resp + in pure $ + Right $ + maybe + "" + ( \c -> case c of + StringContent t -> t + ContentParts _ -> "" + ) + content + chat OpenAI {..} msgs _ = do + eRes <- + createChatCompletion + apiKey + ( defaultChatCompletionRequest + { model = openAIModelName + , messages = toOpenAIMessages msgs + } + ) + case eRes of + Left err -> return $ Left err + Right r -> do + case listToMaybe (choices r) of + Nothing -> return $ Left "Did not received any response" + Just resp -> + let Message {..} = message resp + in pure $ + Right $ + maybe + "" + ( \c -> case c of + StringContent t -> t + ContentParts _ -> "" + ) + content + + stream _ _ _ _ = return $ Left "stream functionality for OpenAI is not supported yet" + +toOpenAIMessages :: LLM.ChatMessage -> [Message] +toOpenAIMessages msgs = map go (NE.toList msgs) + where + toRole r = case r of + LLM.System -> System + LLM.User -> User + LLM.Assistant -> Assistant + LLM.Tool -> Tool + + go :: LLM.Message -> Message + go msg = + defaultMessage + { role = toRole $ LLM.role msg + , content = Just $ StringContent (LLM.content msg) + } diff --git a/src/Langchain/Memory/Core.hs b/src/Langchain/Memory/Core.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Memory/Core.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module : Langchain.Memory.Core +Description : Memory management for LangChain Haskell +Copyright : (c) 2025 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!"] +@ +-} +module Langchain.Memory.Core + ( BaseMemory (..) + , WindowBufferMemory (..) + , trimChatMessage + , addAndTrim + , initialChatMessage + ) where + +import qualified Data.List.NonEmpty as NE +import Data.Text (Text) +import Langchain.LLM.Core (ChatMessage, Message (..), Role (..), defaultMessageData) +import Langchain.Runnable.Core + +{- | Base typeclass for memory implementations +Defines standard operations for chat history management. + +Example instance: + +@ +instance BaseMemory MyMemory where + messages = ... + addUserMessage = ... +@ +-} +class BaseMemory m where + -- | Retrieve current chat history + messages :: m -> IO (Either String ChatMessage) + + -- | Add user message to history + addUserMessage :: m -> Text -> IO (Either String m) + + -- | Add AI response to history + addAiMessage :: m -> Text -> IO (Either String m) + + -- | Add generic message to history + addMessage :: m -> Message -> IO (Either String m) + + -- | Reset memory to initial state + clear :: m -> IO (Either String m) + +{- | Sliding window memory implementation. +Stores chat history with maximum size limit. + +Example: + +>>> let mem = WindowBufferMemory 2 (NE.singleton (Message System "Sys" defaultMessageData)) +>>> addMessage mem (Message User "Hello" defaultMessageData) +Right (WindowBufferMemory {maxWindowSize = 2, ...}) +-} +data WindowBufferMemory = WindowBufferMemory + { maxWindowSize :: Int + -- ^ Maximum number of messages to retain + , windowBufferMessages :: ChatMessage + -- ^ Current message buffer [[9]] + } + 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 {..} msg = + let currentLength = NE.length windowBufferMessages + in if currentLength >= maxWindowSize + then + pure $ + Right $ + winBuffMem + { windowBufferMessages = + NE.fromList $ (NE.tail windowBufferMessages) ++ [msg] + } + else + pure $ + Right $ + winBuffMem + { windowBufferMessages = + windowBufferMessages `NE.append` NE.singleton msg + } + + -- \| Add user message + -- + -- Example: + -- + -- >>> addUserMessage mem "Hello" + -- Right (WindowBufferMemory { ... }) + -- + addUserMessage winBuffMem uMsg = + addMessage winBuffMem (Message User uMsg defaultMessageData) + + -- \| Add AI message + -- + -- Example: + -- + -- >>> addAiMessage mem "Response" + -- Right (WindowBufferMemory { ... }) + -- + addAiMessage winBuffMem uMsg = + addMessage winBuffMem (Message Assistant uMsg defaultMessageData) + + -- \| 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 + } + +{- | Trim chat history to last n messages +Example: + +>>> let msgs = NE.fromList [msg1, msg2, msg3] +>>> trimChatMessage 2 msgs +[msg2, msg3] +-} +trimChatMessage :: Int -> ChatMessage -> ChatMessage +trimChatMessage n msgs = NE.fromList $ drop (max 0 (NE.length msgs - n)) (NE.toList msgs) + +{- | Add and maintain window size +Example: + +>>> let msgs = NE.fromList [msg1] +>>> addAndTrim 2 msg2 msgs +[msg1, msg2] +-} +addAndTrim :: Int -> Message -> ChatMessage -> ChatMessage +addAndTrim n msg msgs = trimChatMessage n (msgs `NE.append` NE.singleton msg) + +{- | Create initial chat history +Example: + +>>> initialChatMessage "You are Qwen" +[Message System "You are Qwen"] +-} +initialChatMessage :: Text -> ChatMessage +initialChatMessage systemPrompt = NE.singleton $ Message System systemPrompt defaultMessageData + +instance Runnable WindowBufferMemory where + type RunnableInput WindowBufferMemory = Text + type RunnableOutput WindowBufferMemory = WindowBufferMemory + + -- \| Runnable interface for user input + -- + -- Example: + -- + -- >>> invoke memory "Hello" + -- Right (WindowBufferMemory { ... }) + -- + invoke memory input = addUserMessage memory input + +{- $examples +Test case patterns: +1. Message trimming + >>> let mem = WindowBufferMemory 2 [msg1, msg2] + >>> addMessage mem msg3 + Right [msg2, msg3] + +2. Initial state + >>> messages (WindowBufferMemory 5 initialMessages) + Right initialMessages + +3. Runnable integration + >>> run (WindowBufferMemory 5 initialMessages) "Hello" + Right (WindowBufferMemory { ... }) +-} diff --git a/src/Langchain/OutputParser/Core.hs b/src/Langchain/OutputParser/Core.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/OutputParser/Core.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module: Langchain.OutputParser.Core +Copyright: (c) 2025 Tushar Adhatrao +License: MIT +Maintainer: Tushar Adhatrao +Stability: experimental + +This module provides the core types and instances for output parsers in the Langchain Haskell port. +Output parsers are used to transform the raw output from language models into structured data formats, +making it easier to work with the results in downstream applications. + +The 'OutputParser' typeclass defines the interface for parsing model output into specific types, +and this module provides instances for common data structures such as booleans, lists, and JSON objects. + +For more information on output parsers in the original Langchain library, see: +https://python.langchain.com/docs/concepts/output_parsers/ +-} +module Langchain.OutputParser.Core + ( -- * Typeclass + OutputParser (..) + + -- * Parsers + , CommaSeparatedList (..) + , JSONOutputStructure (..) + , NumberSeparatedList (..) + ) where + +import Data.Aeson +import Data.ByteString.Char8 (fromStrict) +import Data.Char (isDigit, isSpace) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Text.Internal.Search (indices) + +{- | 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'. +-} +class OutputParser a where + -- | Parse the given text into a value of type 'a'. + -- Returns 'Left' with an error message if parsing fails, or 'Right' with the parsed value. + parse :: Text -> Either String a + +-- | Represents a list of text items separated by commas. +newtype CommaSeparatedList = CommaSeparatedList [Text] + deriving (Show, Eq) + +instance OutputParser Bool where + -- \| Parse a boolean value from the text. + -- The text is considered 'True' if it contains the word "true" (case-insensitive), + -- and 'False' if it contains "false". Otherwise, parsing fails. + -- + -- === Examples + -- + -- \* Parsing "true": + -- + -- @ + -- parse "true" :: Either String Bool == Right True + -- @ + -- + -- \* Parsing "False": + -- + -- @ + -- parse "False" :: Either String Bool == Right False + -- @ + -- + -- \* Parsing invalid input: + -- + -- @ + -- parse "yes" :: Either String Bool == Left "Invalid boolean value" + -- @ + parse txt = do + let txt' = T.strip $ T.toLower txt + if length (indices "true" txt') > 0 + then + Right True + else + if length (indices "false" txt') > 0 + then + Right False + else + Left "Invalid boolean value" + +instance OutputParser CommaSeparatedList where + -- \| Parse a comma-separated list from the text. + -- The text is split by commas, and each part is stripped of leading/trailing whitespace. + -- + -- === Examples + -- + -- \* Parsing an empty string: + -- + -- @ + -- parse "" :: Either String CommaSeparatedList == Right (CommaSeparatedList [""]) + -- @ + -- + -- \* Parsing a single item: + -- + -- @ + -- parse "item" :: Either String CommaSeparatedList == Right (CommaSeparatedList ["item"]) + -- @ + -- + -- \* Parsing multiple items: + -- + -- @ + -- parse "item1,item2,item3" :: Either String CommaSeparatedList == Right (CommaSeparatedList ["item1", "item2", "item3"]) + -- @ + parse txt = Right $ CommaSeparatedList $ map T.strip $ T.splitOn "," txt + +{- | JSON parser wrapper +Requires 'FromJSON' instance for target type. Uses Aeson for parsing. + +Example data type: + +@ +data Person = Person + { name :: Text + , age :: Int + } deriving (Show, Eq, FromJSON) +@ + +Usage: + +>>> parse "{\"name\": \"Bob\", \"age\": 25}" :: Either String (JSONOutputStructure Person) +Right (JSONOutputStructure {jsonValue = Person {name = "Bob", age = 25}}) +-} +newtype FromJSON a => JSONOutputStructure a = JSONOutputStructure + { jsonValue :: a + } + deriving (Show, Eq, FromJSON) + +-- | Instance for parsing JSON into any type that implements FromJSON. +instance FromJSON a => OutputParser (JSONOutputStructure a) where + parse txt = + case eitherDecode (fromStrict $ encodeUtf8 txt) of + Left err -> Left $ "JSON parsing error: " ++ err + Right val -> Right val + +-- | Represents a list of text items separated by numbered prefixes, like "1. First item". +newtype NumberSeparatedList = NumberSeparatedList [Text] + deriving (Show, Eq) + +instance OutputParser NumberSeparatedList where + -- \| Parse a numbered list from the text. + -- The input is expected to be a list of items prefixed with numbers followed by dots, + -- such as "1. First item\n2. Second item". Whitespace is trimmed from each item. + -- + -- === Examples + -- + -- \* Parsing a simple numbered list: + -- + -- @ + -- parse "1. First item\n2. Second item\n3. Third item" :: Either String NumberSeparatedList == Right (NumberSeparatedList ["First item", "Second item", "Third item"]) + -- @ + -- + -- \* Handling whitespace: + -- + -- @ + -- parse "1. First item \n 2. Second item\n3. Third item" :: Either String NumberSeparatedList == Right (NumberSeparatedList ["First item", "Second item", "Third item"]) + -- @ + -- + -- \* Handling multi-digit numbers: + -- + -- @ + -- parse "10. First item\n11. Second item\n12. Third item" :: Either String NumberSeparatedList == Right (NumberSeparatedList ["First item", "Second item", "Third item"]) + -- @ + parse txt = + let s = trim (T.unpack txt) + in case dropUntilAndConsumeBoundary s of + Nothing -> Left "No valid numbered items found" + Just rest -> + -- Parse the rest into items and wrap them in our newtype. + Right . NumberSeparatedList . map (T.pack . trim) $ parseItems rest + +{- | Drops noise until we find a valid boundary marker (number with dot) +and then consumes the marker. +-} +dropUntilAndConsumeBoundary :: String -> Maybe String +dropUntilAndConsumeBoundary s = + case findBoundary s of + Nothing -> Nothing + Just (idx, n) -> Just (drop (idx + n) s) + +{- | Scans the string for the next occurrence of a valid boundary. +Returns the index and length of the marker. +-} +findBoundary :: String -> Maybe (Int, Int) +findBoundary s = go 0 s + where + go _ [] = Nothing + go i xs@(_ : rest) = + case isBoundaryAt xs of + Just n -> Just (i, n) + Nothing -> go (i + 1) rest + +{- | Checks if the given string starts with a valid boundary. +A valid boundary has one or more digits, optional spaces, +a dot, then optional spaces. Returns the number of characters +consumed by the boundary if matched. +-} +isBoundaryAt :: String -> Maybe Int +isBoundaryAt s = + let (digits, rest1) = span isDigit s + in if null digits + then Nothing + else + let (spaces, rest2) = span isSpace rest1 + in case rest2 of + (c : rest3) + | c == '.' -> + let (spaces2, _) = span isSpace rest3 + in Just (length digits + length spaces + 1 + length spaces2) + _ -> Nothing + +-- | Recursively splits the string into items using the boundary markers. +parseItems :: String -> [String] +parseItems s = + case findBoundary s of + Nothing -> [s] -- No further boundaries; the rest is one item. + Just (idx, n) -> + let item = take idx s + rest = drop (idx + n) s + in item : parseItems rest + +-- | A simple trim function to remove leading and trailing whitespace. +trim :: String -> String +trim = f . f + where + f = reverse . dropWhile isSpace diff --git a/src/Langchain/PromptTemplate.hs b/src/Langchain/PromptTemplate.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/PromptTemplate.hs @@ -0,0 +1,166 @@ +{-# 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.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 -> Either String 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 -> Either String Text +renderFewShotPrompt FewShotPromptTemplate {..} = do + -- Format each example using the example template + formattedExamples <- + mapM + (\ex -> interpolate ex 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 -> Either String Text +interpolate vars template = go template + where + go :: Text -> Either String 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 "Unclosed brace" + (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 $ "Missing variable: " <> T.unpack key' + +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/Retriever/Core.hs b/src/Langchain/Retriever/Core.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Retriever/Core.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE TypeFamilies #-} + +{- | +Module : Langchain.Retriever.Core +Description : Retrieval mechanism implementation for LangChain Haskell +Copyright : (c) 2025 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 = "...", ...}, ...] +@ +-} +module Langchain.Retriever.Core + ( Retriever (..) + , VectorStoreRetriever (..) + ) where + +import Langchain.DocumentLoader.Core (Document) +import Langchain.Runnable.Core +import Langchain.VectorStore.Core + +import Data.Text (Text) + +{- | Typeclass for document retrieval systems +Implementations should return documents relevant to a given query. + +Example instance for a custom retriever: + +@ +data CustomRetriever = CustomRetriever + +instance Retriever CustomRetriever where + _get_relevant_documents _ query = do + -- Custom retrieval logic + return $ Right [Document ("Result for: " <> query) mempty] +@ +-} +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 (Either String [Document]) + +{- | 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 + +-- Get similar documents +docs <- _get_relevant_documents vsRetriever "machine learning" +-- Returns top 5 relevant documents by default +@ +-} +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 retriever query = _get_relevant_documents retriever query + +{- $examples +Test case patterns: +1. Basic retrieval + >>> let retriever = VectorStoreRetriever mockStore + >>> _get_relevant_documents retriever "Test" + Right [Document "Test content" ...] + +2. Runnable integration + >>> run retriever "Hello" + Right [Document "Greeting response" ...] + +3. Error handling + >>> _get_relevant_documents (VectorStoreRetriever invalidStore) "Query" + Left "Vector store error" +-} diff --git a/src/Langchain/Retriever/MultiQueryRetriever.hs b/src/Langchain/Retriever/MultiQueryRetriever.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Retriever/MultiQueryRetriever.hs @@ -0,0 +1,288 @@ +{-# 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 + +{- | 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 String [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 String NumberSeparatedList of + Left err -> return $ Left $ "Failed to parse LLM response: " ++ 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 $ "Error generating queries: " ++ 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 "No valid results from any query" + 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 r query = _get_relevant_documents r query + +{- $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 new file mode 100644 --- /dev/null +++ b/src/Langchain/Runnable/Chain.hs @@ -0,0 +1,266 @@ +{-# 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.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 String (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 String (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 String 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 String 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 String 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 String (RunnableOutput r2)) +(|>>) = chain + +infix 4 |>> diff --git a/src/Langchain/Runnable/ConversationChain.hs b/src/Langchain/Runnable/ConversationChain.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Runnable/ConversationChain.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module : Langchain.Runnable.ConversationChain +Description : Stateful conversation handler for LLM interactions +Copyright : (c) 2025 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao + +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 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 ConversationChain {..} input = do + -- Add user message to memory + updatedMemResult <- addUserMessage memory input + case updatedMemResult of + Left err -> return $ Left err + Right updatedMem -> do + -- Get all messages + messagesResult <- messages updatedMem + case messagesResult of + Left err -> return $ Left err + Right allMessages -> do + -- Format messages for the LLM + let formattedMessages = allMessages + -- Get response from LLM + llmResponse <- chat llm formattedMessages Nothing + case llmResponse of + Left err -> return $ Left err + Right response -> do + -- Store AI response in memory + _ <- addAiMessage updatedMem response + return $ Right response diff --git a/src/Langchain/Runnable/Core.hs b/src/Langchain/Runnable/Core.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Runnable/Core.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{- | +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 + +{- | 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 (Either String (RunnableOutput r)) + + -- | Batch process multiple inputs at once. + -- + -- This method can be overridden to provide more efficient batch processing, + -- particularly for components like LLMs that may have batch APIs. + -- + -- The default implementation simply maps 'invoke' over each input and + -- sequences the results. + -- + -- Example usage: + -- + -- @ + -- let retriever = VectorDBRetriever { ... } + -- questions <- ["What is Haskell?", "Explain monads.", "How do I install GHC?"] + -- result <- batch retriever questions + -- case result of + -- Left err -> putStrLn $ "Batch processing failed: " ++ err + -- Right docs -> mapM_ print docs + -- @ + batch :: r -> [RunnableInput r] -> IO (Either String [RunnableOutput r]) + + -- | Default implementation of batch that processes each input sequentially + batch r inputs = do + results <- mapM (invoke r) inputs + return $ sequence results + + -- | Stream results for components that support streaming. + -- + -- This method is particularly useful for LLMs that can stream tokens as they're + -- generated, allowing for more responsive user interfaces. + -- + -- The callback function is called with each piece of the output as it becomes available. + -- + -- Example usage: + -- + -- @ + -- let model = OpenAI { temperature = 0.7, model = "gpt-3.5-turbo", streaming = True } + -- result <- stream model "Write a story about a programmer." $ \chunk -> do + -- putStr chunk + -- hFlush stdout + -- case result of + -- Left err -> putStrLn $ "\\nError: " ++ err + -- Right _ -> putStrLn "\\nStreaming completed successfully." + -- @ + stream :: r -> RunnableInput r -> (RunnableOutput r -> IO ()) -> IO (Either String ()) + + -- | 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 () diff --git a/src/Langchain/Runnable/Utils.hs b/src/Langchain/Runnable/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Runnable/Utils.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# 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.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 _) input = invoke r1 input + +{- | 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 + } + +{- | Create a new cached 'Runnable'. + +This function initializes an empty cache and wraps the provided 'Runnable' +in a 'Cached' wrapper. + +Example: + +@ +main = do + -- Create a cached LLM to avoid redundant API calls + let expensiveModel = OpenAI { model = "gpt-4", temperature = 0.7 } + cachedModel <- cached expensiveModel + + -- These will all use the same cached result for identical inputs + result1 <- invoke cachedModel "What is functional programming?" + result2 <- invoke cachedModel "What is functional programming?" + result3 <- invoke cachedModel "What is functional programming?" + + -- This will compute a new result + result4 <- invoke cachedModel "What is Haskell?" +@ +-} +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 "Operation timed out" diff --git a/src/Langchain/TextSplitter/Character.hs b/src/Langchain/TextSplitter/Character.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/TextSplitter/Character.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.TextSplitter.Character +Description : Character-based text splitting for LLM processing [[10]] +Copyright : (c) 2025 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Character-based text splitting implementation following LangChain's text splitter concepts. +Splits text into chunks based on separators and maximum chunk sizes, useful for processing +large documents with LLMs. + +For more information on text splitting concepts, see the Langchain documentation: +[Langchain TextSplitter](https://python.langchain.com/docs/concepts/text_splitters/). + +Example usage: + +@ +-- Split text using default settings (100 char chunks, double newline separator) +splitText defaultCharacterSplitterOps "Long document text..." + +-- Custom configuration for 500-char chunks with paragraph splitting +customSplit = splitText (CharacterSplitterOps 500 "\n\\s*\n") +@ +-} +module Langchain.TextSplitter.Character + ( -- * Configuration + CharacterSplitterOps (..) + , defaultCharacterSplitterOps + + -- * Splitting Function + , splitText + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +{- | Configuration for character-based text splitting +Contains: + +- 'chunkSize' : Maximum characters per chunk +- 'separator' : Pattern to split text before chunking + +Default values follow LangChain's recommended settings for LLM input preparation. +-} +data CharacterSplitterOps = CharacterSplitterOps + { chunkSize :: Int + , separator :: Text + } + deriving (Show, Eq) + +{- | Default splitter configuration + +- 100 character chunks +- Splits on double newlines ("\n\n") + +>>> defaultCharacterSplitterOps +CharacterSplitterOps {chunkSize = 100, separator = "\n\n"} +-} +defaultCharacterSplitterOps :: CharacterSplitterOps +defaultCharacterSplitterOps = + CharacterSplitterOps + { chunkSize = 100 + , separator = "\n\n" + } + +{- | Split text into chunks following LangChain's splitting strategy: + - +1. Split by separator first +2. Chunk each segment into specified size +3. Preserve semantic boundaries where possible + +Examples: +>>> splitText defaultCharacterSplitterOps "" +[] + +>>> splitText defaultCharacterSplitterOps "Short text" +["Short text"] + +>>> splitText defaultCharacterSplitterOps "Part1\n\nPart2\n\nPart3" +["Part1", "Part2", "Part3"] + +>>> splitText (CharacterSplitterOps 20 "\n\n") "Very long text exceeding chunk size..." +["Very long text ex", "ceeding chunk size..."] +-} +splitText :: CharacterSplitterOps -> Text -> [Text] +splitText CharacterSplitterOps {..} txt = + mconcat $ + map + (T.chunksOf chunkSize . T.strip) + (if T.null separator then [txt] else T.splitOn separator txt) + +{- $examples +Test case patterns demonstrating key behaviors: + +1. Empty input handling + >>> splitText defaultCharacterSplitterOps "" + [] + +2. Custom separator usage + >>> splitText (CharacterSplitterOps 100 "|") "A|B|C" + ["A", "B", "C"] + +3. Combined splitting and chunking + >>> splitText (CharacterSplitterOps 10 "\n") "1234567890\nABCDEFGHIJ" + ["1234567890", "ABCDEFGHIJ"] +-} diff --git a/src/Langchain/Tool/Core.hs b/src/Langchain/Tool/Core.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Tool/Core.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | Module : Langchain.VectorStore.InMemory +Description : In-memory vector store implementation for LangChain Haskell +Copyright : (c) 2025 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 [[9]] 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) +-} +module Langchain.Tool.Core + ( Tool (..) + ) where + +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) diff --git a/src/Langchain/Tool/WebScraper.hs b/src/Langchain/Tool/WebScraper.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Tool/WebScraper.hs @@ -0,0 +1,116 @@ +{-# 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 +-} +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 Network.HTTP.Simple +import Text.HTML.Scalpel + +-- | 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 + , pageHeadings :: [Text] + , pageLinks :: [(Text, Text)] -- (Link text, URL) + , pageText :: 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 = Text + + toolName _ = "web_scraper" + + toolDescription _ = + "Scrapes content from a webpage. Provide a valid URL, and it will extract the title," + <> "headings, links, and text content." + + runTool _ url = do + result <- fetchAndScrape url + case result of + Left err -> pure $ "Error scraping webpage: " <> T.pack (show err) + Right info -> pure $ T.pack (show 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 + let scraped = scrapeStringLike htmlContent scrapeWebPageInfo + case scraped of + Nothing -> pure $ Left "Failed to parse HTML content" + Just info -> pure $ Right info + +-- | Define the Scalpel scraper for extracting webpage information +scrapeWebPageInfo :: Scraper Text WebPageInfo +scrapeWebPageInfo = do + title <- scrapeTitle + headings <- scrapeHeadings + links <- scrapeLinks + t <- scrapeText + return $ WebPageInfo title headings links t + +-- | Scrape the page title +scrapeTitle :: Scraper Text (Maybe Text) +scrapeTitle = fmap listToMaybe $ texts "title" + +-- | Scrape all headings (h1-h6) +scrapeHeadings :: Scraper Text [Text] +scrapeHeadings = do + h1s <- texts "h1" + h2s <- texts "h2" + h3s <- texts "h3" + h4s <- texts "h4" + h5s <- texts "h5" + h6s <- texts "h6" + return $ concat [h1s, h2s, h3s, h4s, h5s, h6s] + +-- | Scrape all links with their URLs +scrapeLinks :: Scraper Text [(Text, Text)] +scrapeLinks = chroots "a" $ do + linkText <- text "a" + linkHref <- attr "href" "a" + return (linkText, linkHref) + +-- | Scrape main text content (from p, div, span elements) +scrapeText :: Scraper Text Text +scrapeText = do + paragraphs <- texts "p" + divs <- texts "div" + spans <- texts "span" + listElems <- texts "li" + return $ T.intercalate "\n\n" $ filter (not . T.null) $ concat [paragraphs, divs, spans, listElems] diff --git a/src/Langchain/Tool/WikipediaTool.hs b/src/Langchain/Tool/WikipediaTool.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Tool/WikipediaTool.hs @@ -0,0 +1,287 @@ +{-# 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 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 = 2 + +-- | 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 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 tool q = searchWiki tool q + +-- | 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) . 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. +data SearchResponse = SearchResponse + { query :: SearchQuery + } + deriving (Show, Generic, FromJSON) + +-- | Type for list of search result +data 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 +data PageResponse = PageResponse + { query :: Pages + } + deriving (Generic, Eq, Show, FromJSON) + +-- | Collection of Wikipedia pages, where key is page id +data 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 = fmap Right $ runTool tool input diff --git a/src/Langchain/VectorStore/Core.hs b/src/Langchain/VectorStore/Core.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/VectorStore/Core.hs @@ -0,0 +1,105 @@ +{- | +Module : Langchain.VectorStore.Core +Description : Core vector store abstraction for semantic search +Copyright : (c) 2025 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 +@ +-} +module Langchain.VectorStore.Core (VectorStore (..)) +where + +import Data.Int (Int64) +import Data.Text (Text) +import Langchain.DocumentLoader.Core + +-- 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]] + } + +instance VectorStore InMemoryStore where + addDocuments store docs = ... + similaritySearch store query k = ... +@ +-} +class VectorStore m where + -- | Add documents to the vector store + -- + -- Example: + -- + -- >>> addDocuments myStore [Document "Test content" mempty] + -- Right (updatedStoreWithNewDocs) + addDocuments :: m -> [Document] -> IO (Either String m) + + -- | + -- Requires document ID tracking to be implemented in store instances. + -- + -- Example usage (when implemented): + -- + -- >>> delete myStore [123] + -- Right (storeWithoutDoc123) + delete :: m -> [Int64] -> IO (Either String m) + + -- | 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 :: m -> Text -> Int -> IO (Either String [Document]) + + -- | Find documents similar to vector representation + -- For direct vector comparisons without text conversion. + -- + -- Example: + -- + -- >>> similaritySearchByVector store [0.1, 0.3, ...] 5 + -- Right [mostSimilarDoc1, ...] + similaritySearchByVector :: m -> [Float] -> Int -> IO (Either String [Document]) + +{- $examples +Test case patterns: +1. Document addition + >>> addDocuments emptyStore [doc1, doc2] + Right (storeWithDocs) + +2. Similarity search + >>> similaritySearch populatedStore "AI" 3 + Right [relevantDoc1, relevantDoc2, relevantDoc3] + +3. Vector-based search + >>> similaritySearchByVector store [0.5, 0.2, ...] 5 + Right [top5MatchingDocs] +-} diff --git a/src/Langchain/VectorStore/InMemory.hs b/src/Langchain/VectorStore/InMemory.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/VectorStore/InMemory.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.VectorStore.InMemory +Description : In-memory vector store implementation for LangChain Haskell +Copyright : (c) 2025 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"...] +@ +-} +module Langchain.VectorStore.InMemory + ( InMemory (..) + , fromDocuments + , emptyInMemoryVectorStore + , norm + , dotProduct + , cosineSimilarity + ) where + +import Data.Int (Int64) +import Data.List (sortBy) +import qualified Data.Map.Strict as Map +import Data.Ord (comparing) +import Langchain.DocumentLoader.Core (Document) +import Langchain.Embeddings.Core +import Langchain.VectorStore.Core + +{- | Compute dot product of two vectors +Example: + +>>> dotProduct [1,2,3] [4,5,6] +32.0 +-} +dotProduct :: [Float] -> [Float] -> Float +dotProduct a b = sum $ zipWith (*) a b + +{- | Calculate Euclidean norm of a vector +Example: + +>>> norm [3,4] +5.0 +-} +norm :: [Float] -> Float +norm a = sqrt $ sum $ map (^ (2 :: Int)) a + +{- | Calculate cosine similarity between vectors +Example: + +>>> cosineSimilarity [1,2] [2,4] +1.0 +-} +cosineSimilarity :: [Float] -> [Float] -> Float +cosineSimilarity a b = dotProduct a b / (norm a * norm b) + +{- | Create empty in-memory store with embedding model +Example: + +>>> emptyInMemoryVectorStore ollamaEmb +InMemory {_embeddingModel = ..., _store = empty} +-} +emptyInMemoryVectorStore :: Embeddings m => 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 String (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 + + -- \| Delete documents by ID + -- Example: + -- + -- >>> delete inMem [1, 2] + -- Right (InMemory {_store = ...}) + -- + delete inMem ids = do + let currStore = store inMem + newStore = foldl (\acc i -> Map.delete i acc) currStore ids + newInMem = inMem {store = newStore} + pure $ Right newInMem + + -- \| 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 + + -- \| 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 + (\(doc, vec) -> (doc, cosineSimilarity queryVec vec)) + (map 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] +-} diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,42 @@ +import qualified Test.Langchain.Agent.Core as AgentTest +import qualified Test.Langchain.Agent.ReactAgent as ReactAgentTest +import qualified Test.Langchain.DocumentLoader.Core as DocumentLoaderTest +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.Memory.Core as MemoryTest +import qualified Test.Langchain.OutputParser.Core as OutputParserTest +import qualified Test.Langchain.PromptTemplate as PromptTemplateTest +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.TextSplitter.Character as TextSplitterTest +import qualified Test.Langchain.Tool.Core as ToolTest +import qualified Test.Langchain.VectorStore.Core as VectorStoreTest +import Test.Tasty + +main :: IO () +main = + defaultMain $ + testGroup + "Langchain" + [ LLMCoreTest.tests + , OllamaLLMTest.tests + , PromptTemplateTest.tests + , OutputParserTest.tests + , TextSplitterTest.tests + , DocumentLoaderTest.tests + , MemoryTest.tests + , VectorStoreTest.tests + , EmbeddingsTest.tests + , RetrieverTest.tests + , ToolTest.tests + , AgentTest.tests + , ReactAgentTest.tests + , RunnableTest.tests + , RunnableUtilsTest.tests + , RunnableChainsTest.tests + , ConverationChainsTest.tests + ] diff --git a/test/Test/Langchain/Agent/Core.hs b/test/Test/Langchain/Agent/Core.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Agent/Core.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Langchain.Agent.Core (tests) where + +import Control.Exception (throwIO) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import Data.Text (Text, isInfixOf, pack) +import Langchain.Agents.Core +import Langchain.LLM.Core +import Langchain.Memory.Core (BaseMemory (..)) +import Langchain.PromptTemplate +import Langchain.Tool.Core (Tool (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, testCase) + +data DummyTool = DummyTool deriving (Show) + +instance Tool DummyTool where + type Input DummyTool = Text + type Output DummyTool = Text + toolName _ = "dummy-tool" + toolDescription _ = "dummy tool description" + runTool _ input = return $ "Processed: " <> input + +data FaultyTool = FaultyTool deriving (Show) + +instance Tool FaultyTool where + type Input FaultyTool = Text + type Output FaultyTool = Text + toolName _ = "faulty-tool" + toolDescription _ = "fulty tool description" + runTool _ _ = throwIO $ userError "Intentional tool error" + +data StepSequenceAgent = StepSequenceAgent (IORef [AgentStep]) [AnyTool] + +instance Agent StepSequenceAgent where + planNextAction (StepSequenceAgent ref _) _ = do + steps <- readIORef ref + case steps of + [] -> return $ Left "No steps left" + (step : rest) -> do + writeIORef ref rest + return $ Right step + agentTools (StepSequenceAgent _ tools) = return tools + agentPrompt _ = return $ PromptTemplate "test prompt" + +-- Test Memory Implementation + +data TestMemory = TestMemory [Message] + +instance BaseMemory TestMemory where + addMessage (TestMemory msgs) newMsg = return $ Right $ TestMemory (msgs ++ [newMsg]) + addUserMessage (TestMemory msgs) input = do + let userMsg = Message User input defaultMessageData + return $ Right $ TestMemory (msgs ++ [userMsg]) + addAiMessage (TestMemory msgs) input = do + let aiMsg = Message System input defaultMessageData + return $ Right $ TestMemory (msgs ++ [aiMsg]) + messages (TestMemory msgs) = return $ Right $ NE.fromList msgs + clear _ = return $ Right (TestMemory []) + +tests :: TestTree +tests = + testGroup + "Agent Tests" + [ testCase "executeTool valid tool" $ do + let dummyAnyTool = customAnyTool DummyTool id id + tools = [dummyAnyTool] + result <- executeTool tools "dummy-tool" "test input" + assertEqual "Should process input" (Right "Processed: test input") result + , testCase "executeTool tool not found" $ do + let tools = [] + result <- executeTool tools "unknown-tool" "input" + assertEqual "Should return tool not found error" (Left "Tool not found: unknown-tool") result + , testCase "executeTool tool throws exception" $ do + let faultyAnyTool = customAnyTool FaultyTool id id + tools = [faultyAnyTool] + result <- executeTool tools "faulty-tool" "input" + assertBool + "Should return execution error" + ("Intentional tool error" `isInfixOf` (pack $ fromLeft "" result)) + , testCase "runAgentLoop max iterations exceeded" $ do + agentRef <- newIORef [] + let agent = StepSequenceAgent agentRef [] + initialState = AgentState (TestMemory []) [] [] + result <- runAgentLoop agent initialState 10 5 + assertEqual "Should return max iteration error" (Left "Max iterations excedded") result + , testCase "runAgent immediate finish" $ do + agentRef <- newIORef [Finish (AgentFinish (Map.singleton "result" "success") "Finished")] + let agent = StepSequenceAgent agentRef [] + initialState = AgentState (TestMemory []) [] [] + result <- runAgent agent initialState "input" + assertEqual + "Should return finish result" + (Right (AgentFinish (Map.singleton "result" "success") "Finished")) + result + , testCase "runAgentLoop continue then finish" $ do + agentRef <- + newIORef + [ Continue (AgentAction "dummy-tool" "input" "log") + , Finish (AgentFinish Map.empty "Done") + ] + let dummyAnyTool = customAnyTool DummyTool id id + agent = StepSequenceAgent agentRef [dummyAnyTool] + initialState = AgentState (TestMemory []) [] [] + result <- runAgentLoop agent initialState 0 10 + assertEqual "Should finish after one step" (Right (AgentFinish Map.empty "Done")) result + , testCase "customAnyTool wraps correctly" $ do + let tool = customAnyTool DummyTool id id + input = "test" + expectedOutput = "Processed: test" + result <- executeTool [tool] "dummy-tool" input + assertEqual "Should apply conversions" (Right expectedOutput) result + ] + where + fromLeft :: a -> Either a b -> a + fromLeft _ (Left x) = x + fromLeft def _ = def diff --git a/test/Test/Langchain/Agent/ReactAgent.hs b/test/Test/Langchain/Agent/ReactAgent.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Agent/ReactAgent.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Langchain.Agent.ReactAgent (tests) where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, assertEqual, assertBool) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.List.NonEmpty as NE +import Langchain.Agents.Core +import Langchain.Agents.React +import Langchain.LLM.Core +import Langchain.Memory.Core (BaseMemory(..)) +import Langchain.Tool.Core (Tool(..)) + +--TODO: Need to fix answering parsing by stripping ": " +data MockLLM = MockLLM { mockResponse :: Text } + +instance LLM MockLLM where + generate _ _ _ = undefined + chat (MockLLM resp) _ _ = return $ Right resp + stream _ _ _ _ = undefined + +data DummyTool = DummyTool deriving (Show) + +instance Tool DummyTool where + type Input DummyTool = Text + type Output DummyTool = Text + toolName _ = "dummy-tool" + toolDescription _ = "A dummy tool for testing" + runTool _ input = return $ "Processed: " <> input + +data TestMemory = TestMemory [Message] + +instance BaseMemory TestMemory where + addMessage (TestMemory msgs) newMsg = return $ Right $ TestMemory (msgs ++ [newMsg]) + addUserMessage (TestMemory msgs) input = do + let userMsg = Message User input defaultMessageData + return $ Right $ TestMemory (msgs ++ [userMsg]) + addAiMessage (TestMemory msgs) input = do + let aiMsg = Message System input defaultMessageData + return $ Right $ TestMemory (msgs ++ [aiMsg]) + messages (TestMemory msgs) = return $ return $ NE.fromList msgs + clear _ = pure $ Right $ TestMemory [] + +tests :: TestTree +tests = testGroup "React Agent Tests" + [ testCase "parseReactOutput final answer" $ do + let input = "Thought: I know the answer\nFinal Answer: Success" + let result = parseReactOutput input + case result of + Right (ReactAgentOutputParser (Finish (AgentFinish vals _))) -> + assertEqual "Should parse final answer" (Map.singleton "output" ": Success") vals + _ -> assertBool "Failed to parse final answer" False + + , testCase "parseReactOutput action step" $ do + let input = "Action: dummy-tool\nAction Input: test input" + let result = parseReactOutput input + case result of + Right (ReactAgentOutputParser (Continue act)) -> do + assertEqual "Correct tool name" ": dummy-tool" (actionToolName act) + assertEqual "Correct input" ": test input" (actionInput act) + _ -> assertBool "Failed to parse action" False + + , testCase "parseReactOutput invalid input" $ do + let input = "Invalid format" + let result = parseReactOutput input + case result of + Left err -> assertBool "Should return parse error" ("Could not parse" `T.isInfixOf` (T.pack err)) + _ -> assertBool "Should fail on invalid input" False + + , testCase "planNextAction generates action step" $ do + let llm = MockLLM { mockResponse = "Action: dummy-tool\nAction Input: test" } + let tools = [customAnyTool DummyTool id id] + agent <- createReactAgent llm tools + case agent of + Left _ -> assertBool "Agent creation failed" False + Right reactAgent -> do + let mem = TestMemory [Message User "Solve this" defaultMessageData] + let state = AgentState mem [] [] + result <- planNextAction reactAgent state + case result of + Right (Continue act) -> do + assertEqual "Correct tool name" ": dummy-tool" (actionToolName act) + assertEqual "Correct input" ": test" (actionInput act) + _ -> assertBool "Should generate action step" False + + , testCase "planNextAction final answer" $ do + let llm = MockLLM { mockResponse = "Final Answer: 42" } + let tools = [] + agent <- createReactAgent llm tools + case agent of + Left _ -> assertBool "Agent creation failed" False + Right reactAgent -> do + let mem = TestMemory [Message User "What's the answer?" defaultMessageData] + let state = AgentState mem [] [] + result <- planNextAction reactAgent state + case result of + Right (Finish (AgentFinish vals _)) -> + assertEqual "Correct final answer" (Map.singleton "output" ": 42") vals + _ -> assertBool "Should generate final answer" False + + , testCase "createReactAgent prompt formatting" $ do + let llm = MockLLM { mockResponse = "" } + let tools = [customAnyTool DummyTool id id] + agent <- createReactAgent llm tools + case agent of + Right ReactAgent {..} -> do + let expectedTools = "Tool: dummy-tool\nDescription: A dummy tool for testing" + expectedNames = "dummy-tool" + assertEqual "Correct tool descriptions" expectedTools (formatToolDescriptions reactTools) + assertEqual "Correct tool names" expectedNames (formatToolNames reactTools) + _ -> assertBool "Agent creation failed" False + + , testCase "getLastUserInput retrieves last user message" $ do + let msgs = NE.fromList [ Message User "First" defaultMessageData + , Message Assistant "Response" defaultMessageData + , Message User "Last" defaultMessageData ] + let result = getLastUserInput msgs + assertEqual "Should get last user input" "Last" result + + , testCase "getLastUserInput no user messages" $ do + let msgs = NE.fromList [ Message Assistant "Only" defaultMessageData ] + let result = getLastUserInput msgs + assertEqual "Should return empty" "" result + ] + where + -- isLeft (Left _) = True + -- isLeft _ = False diff --git a/test/Test/Langchain/DocumentLoader/Core.hs b/test/Test/Langchain/DocumentLoader/Core.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/DocumentLoader/Core.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.DocumentLoader.Core (tests) where + +import Data.Aeson (Value (..)) +import Data.Map (empty, fromList) +import qualified Data.Map as Map +import qualified Data.Text as T +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.DocumentLoader.Core +import Langchain.DocumentLoader.FileLoader + +createTestFile :: FilePath -> String -> IO () +createTestFile path content = writeFile path content + +withTestFile :: String -> (FilePath -> IO a) -> IO a +withTestFile content action = + withSystemTempDirectory "test-doc-loader" $ \dir -> do + let filePath = dir "test-file.txt" + createTestFile filePath content + action filePath + +documentTests :: TestTree +documentTests = + testGroup + "Document Tests" + [ testCase "Document Semigroup instance should concatenate content and metadata" $ do + let doc1 = Document "Hello" (fromList [("source", String "file1")]) + doc2 = Document " World" (fromList [("page", Number 1)]) + combined = doc1 <> doc2 + pageContent combined @?= "Hello World" + metadata combined @?= fromList [("source", String "file1"), ("page", Number 1)] + , testCase "Document Monoid instance should have identity element" $ do + let doc = Document "Content" (fromList [("key", String "value")]) + doc <> mempty @?= doc + mempty <> doc @?= doc + pageContent mempty @?= "" + metadata mempty @?= empty + ] + +fileLoaderTests :: TestTree +fileLoaderTests = + testGroup + "FileLoader Tests" + [ testCase "load should return document with file content and metadata" $ + withTestFile "Test content for the file." $ \filePath -> do + result <- load (FileLoader filePath) + case result of + Left err -> assertFailure $ "Expected Right but got Left: " ++ err + Right docs@(doc : _) -> do + length docs @?= 1 + pageContent doc @?= "Test content for the file." + 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") + case result of + Left err -> + assertBool + "Error message should mention file not found" + (T.isInfixOf "File not found" (T.pack 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) + case result of + Left err -> assertFailure $ "Expected Right but got Left: " ++ 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") + case result of + Left err -> + assertBool + "Error message should mention file not found" + (T.isInfixOf "File not found" (T.pack 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) + case result of + Left err -> assertFailure $ "Expected Right but got Left: " ++ err + Right docs@(doc : _) -> do + length docs @?= 1 + pageContent doc @?= "" + 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) + case result of + Left err -> assertFailure $ "Expected Right but got Left: " ++ err + Right docs@(doc : _) -> do + length docs @?= 1 + T.length (pageContent doc) @?= 21000 -- 21 chars * 1000 + Right _ -> assertFailure "Document list is empty" + ] + +tests :: TestTree +tests = + testGroup + "Langchain.DocumentLoader Tests" + [ documentTests + , fileLoaderTests + ] diff --git a/test/Test/Langchain/Embeddings/Core.hs b/test/Test/Langchain/Embeddings/Core.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Embeddings/Core.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Embeddings.Core (tests) where + +-- import Data.Ollama.Embeddings (EmbeddingResp (..)) +import Data.Text (isInfixOf, pack) +import Langchain.DocumentLoader.Core +import Langchain.Embeddings.Core +import Langchain.Embeddings.Ollama +import Test.Tasty +import Test.Tasty.HUnit + +{- +mockSuccessResponse :: EmbeddingResp +mockSuccessResponse = EmbeddingResp { embedding_ = [[1.0, 2.0, 3.0]] } + +mockEmptyResponse :: EmbeddingResp +mockEmptyResponse = EmbeddingResp { embedding_ = [] } +-} + +tests :: TestTree +tests = + testGroup + "Embedding Tests" + [ testGroup + "embedQuery Tests" + [ testCase "Returns embedding on successful response" $ do + let embeddings = OllamaEmbeddings "llama3.2:latest" Nothing Nothing + result <- embedQuery embeddings "test query" + case result of + Left err -> assertFailure $ "Expected success, got error: " ++ err + Right vec -> assertEqual "Correct embedding length" 3072 (length vec) + , {- + , testCase "Handles empty embedding response" $ do + let embeddings = OllamaEmbeddings "nomic-embed-text:latest" Nothing Nothing + -- Assuming embeddingOps returns Right mockEmptyResponse + result <- embedQuery embeddings "empty query" + case result of + Left err -> assertEqual "Correct error message" "Embeddings are empty" err + Right _ -> assertFailure ("Expected error for empty embedding") + -} + testCase "Propagates API errors" $ do + let embeddings = OllamaEmbeddings "error-model" 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` (pack err)) + Right _ -> assertFailure "Expected API error propagation" + ] + , testGroup + "embedDocuments Tests" + [ testCase "Processes multiple documents successfully" $ do + let embeddings = OllamaEmbeddings "llama3.2:latest" Nothing Nothing + docs = replicate 3 (Document "content" mempty) + -- Assuming each embeddingOps call returns Right mockSuccessResponse + result <- embedDocuments embeddings docs + case result of + Left err -> assertFailure $ "Unexpected error: " ++ err + Right vecs -> assertEqual "Correct number of embeddings" 3 (length vecs) + {- + , testCase "Handles document processing errors" $ do + let embeddings = OllamaEmbeddings "nomic-embed-text:latest" Nothing Nothing + docs = [Document "good" mempty, Document "bad" mempty] + -- Assuming second embeddingOps call returns Left "Partial Failure" + result <- embedDocuments embeddings docs + case result of + Left err -> assertBool "Error contains 'Partial Failure'" ("Partial Failure" `isInfixOf` (pack err)) + Right _ -> assertFailure "Expected partial failure error" + , testCase "Detects empty embeddings in response" $ do + let embeddings = OllamaEmbeddings "empty-embed-model" Nothing Nothing + docs = [Document "empty" mempty] + -- Assuming embeddingOps returns Right mockEmptyResponse + result <- embedDocuments embeddings docs + case result of + Left err -> assertEqual "Correct empty embedding error" "Embeddings are empty" err + Right _ -> assertFailure "Expected empty embedding error" + -} + ] + ] + diff --git a/test/Test/Langchain/LLM/Core.hs b/test/Test/Langchain/LLM/Core.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/LLM/Core.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Test.Langchain.LLM.Core (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Data.Aeson (Result (..), decode, encode, fromJSON, toJSON) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text (Text) +import Langchain.LLM.Core + +data TestLLM = TestLLM + { responseText :: Text + , shouldSucceed :: Bool + } + +instance LLM TestLLM where + generate m _ _ = + pure $ + if shouldSucceed m + then Right (responseText m) + else Left "Test error" + + chat m _ _ = + pure $ + if shouldSucceed m + then Right (responseText m) + else Left "Test error" + + stream m _ handler _ = do + if shouldSucceed m + then do + onToken handler (responseText m) + onComplete handler + pure (Right ()) + else pure (Left "Test error") + +tests :: TestTree +tests = + testGroup + "LLMCoreTest" + [ testGroup + "Params" + [ testCase "creates default parameters with all Nothing fields" $ do + let params = defaultParams + assertEqual "temperature should be Nothing" Nothing (temperature params) + assertEqual "maxTokens should be Nothing" Nothing (maxTokens params) + assertEqual "topP should be Nothing" Nothing (topP params) + assertEqual "n should be Nothing" Nothing (n params) + assertEqual "stop should be Nothing" Nothing (stop params) + , testCase "can override default parameters" $ do + let params = defaultParams {temperature = Just 0.7, maxTokens = Just 100} + assertEqual "temperature should be Just 0.7" (Just 0.7) (temperature params) + assertEqual "maxTokens should be Just 100" (Just 100) (maxTokens params) + assertEqual "topP should be Nothing" Nothing (topP params) + ] + , 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 + assertEqual "Partial JSON decoding of MessageData" (Just expected) (decode json) + ] + , testGroup + "LLM Typeclass" + [ testGroup + "generate" + [ 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 "Test error") result + , testCase "works with custom parameters" $ do + let successLLM = TestLLM "Success response" True + params = defaultParams {temperature = Just 0.5} + result <- generate successLLM "Test prompt" (Just params) + assertEqual "Generation with custom params" (Right "Success response") 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 + assertEqual "Successful chat" (Right "Success response") 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 "Test error") 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 "Test error") 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 new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/LLM/Ollama.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# 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 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 = "llama3.2:latest" + +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: " ++ 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 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: " ++ err + Right response -> do + assertBool "Response should mention Paris" ("paris" `T.isInfixOf` T.toLower 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: " ++ err + Right response -> assertBool "Response should mention Rome" ("rome" `T.isInfixOf` T.toLower 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 [] + completedRef <- newIORef False + + let handler = + StreamHandler + { onToken = \token -> modifyIORef tokensRef (token :) + , onComplete = writeIORef completedRef True + } + + result <- stream ollama messages handler Nothing + case result of + Left err -> assertFailure $ "Expected success, got error: " ++ err + Right () -> do + tokens <- readIORef tokensRef + assertBool "Should receive tokens" (not (null tokens)) + completed <- readIORef completedRef + completed @?= True + , 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 + case result of + Left err -> assertFailure $ "Expected success, got error: " ++ err + Right response -> assertBool "Should mention 4" ("4" `T.isInfixOf` T.toLower response) + ] + where + isErrorEvent (LLMError _) = True + isErrorEvent _ = False + + shouldContainAll xs ys = all (`elem` xs) ys diff --git a/test/Test/Langchain/Memory/Core.hs b/test/Test/Langchain/Memory/Core.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Memory/Core.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Memory.Core (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.LLM.Core (Message (..), Role (..), defaultMessageData) +import Langchain.Memory.Core +import Langchain.Runnable.Core + +import qualified Data.List.NonEmpty as NE +import Data.Text (Text) + +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 + +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 + 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"] + ] + +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: " ++ 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: " ++ err + Right newMemory -> do + msgsResult <- messages newMemory + case msgsResult of + Left err -> assertFailure $ "Expected Right but got Left: " ++ err + Right msgs -> NE.toList msgs @?= [systemMsg "System", userMsg "User1"] + , testCase "addMessage should maintain max window size" $ 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: " ++ err + Right newMemory -> do + msgsResult <- messages newMemory + case msgsResult of + Left err -> assertFailure $ "Expected Right but got Left: " ++ err + Right msgs -> do + NE.length msgs @?= 3 + NE.toList msgs @?= [userMsg "User1", 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: " ++ err + Right newMemory -> do + msgsResult <- messages newMemory + case msgsResult of + Left err -> assertFailure $ "Expected Right but got Left: " ++ 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: " ++ err + Right newMemory -> do + msgsResult <- messages newMemory + case msgsResult of + Left err -> assertFailure $ "Expected Right but got Left: " ++ 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 + 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: " ++ err + Right newMemory -> do + msgsResult <- messages newMemory + case msgsResult of + Left err -> assertFailure $ "Expected Right but got Left: " ++ err + Right msgs -> do + NE.length msgs @?= 1 + NE.head msgs @?= systemMsg "You are an AI model" + ] + +runnableTests :: TestTree +runnableTests = + 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" + case result of + Left err -> assertFailure $ "Expected Right but got Left: " ++ err + Right newMemory -> do + msgsResult <- messages newMemory + case msgsResult of + Left err -> assertFailure $ "Expected Right but got Left: " ++ 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 + ] diff --git a/test/Test/Langchain/OutputParser/Core.hs b/test/Test/Langchain/OutputParser/Core.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/OutputParser/Core.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.OutputParser.Core (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Data.Aeson +import Data.Text (Text) +import Langchain.OutputParser.Core + +data Person = Person + { name :: Text + , age :: Int + } + deriving (Show, Eq) + +instance FromJSON Person where + parseJSON = withObject "Person" $ \v -> + Person + <$> v .: "name" + <*> v .: "age" + +tests :: TestTree +tests = + testGroup + "OutputParser Tests" + [ testCase "Bool parser should parse 'true'" $ + (parse "true" :: Either String Bool) @?= Right True + , testCase "Bool parser should parse 'True'" $ + (parse "True" :: Either String Bool) @?= Right True + , testCase "Bool parser should parse 'TRUE'" $ + (parse "TRUE" :: Either String Bool) @?= Right True + , testCase "Bool parser should parse 'true' with whitespace" $ + (parse " true " :: Either String Bool) @?= Right True + , testCase "Bool parser should parse 'false'" $ + (parse "false" :: Either String Bool) @?= Right False + , testCase "Bool parser should parse 'False'" $ + (parse "False" :: Either String Bool) @?= Right False + , testCase "Bool parser should parse 'FALSE'" $ + (parse "FALSE" :: Either String Bool) @?= Right False + , testCase "Bool parser should parse 'false' with whitespace" $ + (parse " false " :: Either String Bool) @?= Right False + , testCase "Bool parser should fail on invalid input" $ + case parse "not a boolean" :: Either String Bool of + Left _ -> assertBool "Should be Left" True + Right _ -> assertFailure "Should have failed parsing" + , testCase "CommaSeparatedList parser should parse empty string" $ + parse "" @?= Right (CommaSeparatedList [""]) + , testCase "CommaSeparatedList parser should parse single item" $ + parse "item" @?= Right (CommaSeparatedList ["item"]) + , testCase "CommaSeparatedList parser should parse multiple items" $ + parse "item1,item2,item3" @?= Right (CommaSeparatedList ["item1", "item2", "item3"]) + , testCase "CommaSeparatedList parser should trim whitespace" $ + parse " item1 , item2 , item3 " @?= Right (CommaSeparatedList ["item1", "item2", "item3"]) + , testCase "JSONOutputStructure parser should parse valid JSON" $ + parse "{\"name\":\"John\",\"age\":30}" @?= (Right (JSONOutputStructure (Person "John" 30))) + , testCase "JSONOutputStructure parser should fail on invalid JSON" $ + case parse "{not valid json}" :: Either String (JSONOutputStructure Person) of + Left _ -> assertBool "Should be Left" True + Right _ -> assertFailure "Should have failed parsing" + , testCase "NumberSeparatedList parser should parse numbered list" $ + parse "1. First item\n2. Second item\n3. Third item" + @?= Right (NumberSeparatedList ["First item", "Second item", "Third item"]) + , testCase "NumberSeparatedList parser should handle whitespace" $ + parse "1. First item \n 2. Second item\n3. Third item" + @?= Right (NumberSeparatedList ["First item", "Second item", "Third item"]) + , testCase "NumberSeparatedList parser should handle multi-digit numbers" $ + parse "10. First item\n11. Second item\n12. Third item" + @?= Right (NumberSeparatedList ["First item", "Second item", "Third item"]) + , testCase "NumberSeparatedList parser should handle text before numbered list" $ + parse "Here is a list:\n1. First item\n2. Second item" + @?= Right (NumberSeparatedList ["First item", "Second item"]) + , testCase "NumberSeparatedList parser should handle whitespace between number and dot" $ + parse "1 . First item\n2 . Second item" + @?= Right (NumberSeparatedList ["First item", "Second item"]) + , testCase "NumberSeparatedList parser should fail if no numbers are found" $ + case parse "No numbers here, just text" :: Either String NumberSeparatedList of + Left _ -> assertBool "Should be Left" True + Right _ -> assertFailure "Should have failed parsing" + ] diff --git a/test/Test/Langchain/PromptTemplate.hs b/test/Test/Langchain/PromptTemplate.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/PromptTemplate.hs @@ -0,0 +1,90 @@ +{-# 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 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 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/Retriever/Core.hs b/test/Test/Langchain/Retriever/Core.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Retriever/Core.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Retriever.Core (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.DocumentLoader.Core (Document (..)) +import Langchain.LLM.Core (LLM (..)) +import Langchain.Retriever.Core (Retriever (..)) +import Langchain.Retriever.MultiQueryRetriever + +import qualified Data.Map.Strict as HM + +data DummyLLM = DummyLLM + +--TODO: Add some real world examples here +instance LLM DummyLLM where + -- 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 "dummy chat response" + stream _ _ _ _ = return $ Right () + +data DummyRetriever = DummyRetriever + +instance Retriever DummyRetriever where + _get_relevant_documents _ query = + return $ Right [Document (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: " ++ 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: " ++ 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 + +tests :: TestTree +tests = + testGroup + "Retriever Tests" + [ testCase "generateQueries returns expected queries" test_generateQueries + , testCase "MultiQueryRetriever retrieves and combines documents" test_MultiQueryRetriever + ] diff --git a/test/Test/Langchain/Runnable/Chains.hs b/test/Test/Langchain/Runnable/Chains.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Runnable/Chains.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Langchain.Runnable.Chains (tests) where + +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 (\x -> return $ Right (even x)) + +failingMock :: MockRunnable a b +failingMock = MockRunnable (\_ -> return $ Left "Mock error") + +data MockRunnable a b = MockRunnable {runMock :: a -> IO (Either String 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 "Mock error") 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 "Mock error" :: Either String (Bool, Int)) result + ] + ] diff --git a/test/Test/Langchain/Runnable/ConversationChains.hs b/test/Test/Langchain/Runnable/ConversationChains.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Runnable/ConversationChains.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +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.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, (@?=)) + +data 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 + (modifyIORef ref (const [])) + return $ Right $ TestMemory ref + + messages (TestMemory ref) = fmap Right (NE.fromList <$> readIORef ref) + +data FailingMemory = FailingMemory + +instance BaseMemory FailingMemory where + addUserMessage _ _ = return $ Left "Memory error" + addAiMessage _ _ = return $ Left "Memory error" + messages _ = return $ Left "memory error" + addMessage _ _ = return $ Left "memory error" + clear _ = return $ Left "memory error" + +data MockLLM = MockLLM + { llmResponse :: Either String Text + , receivedMessages :: IORef [Message] + } + +instance LLM MockLLM where + 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 "Hello!") 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 "") nRef + chain = ConversationChain failingMem mockLLM (PromptTemplate "") + result <- invoke chain "Hi" + result @?= Left "Memory error" + , testCase "LLM returns error" $ do + memRef <- newIORef [] + let testMem = TestMemory memRef + msgRef <- newIORef [] + let mockLLM = MockLLM (Left "LLM error") msgRef + chain = ConversationChain testMem mockLLM (PromptTemplate "") + result <- invoke chain "Hi" + result @?= Left "LLM error" + -- 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 "Response") 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 new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Runnable/Core.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Langchain.Runnable.Core (tests) where + +import Data.IORef (modifyIORef, newIORef, readIORef) +import Langchain.Runnable.Core +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertEqual, testCase) + +data MockRunnable a b = MockRunnable + { runMock :: a -> IO (Either String 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 "mock error") + result <- invoke mock "input" + assertEqual "Should return error" (Left "mock error" :: Either String 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 "error in batch") + else return (Right (s ++ "!")) + result <- batch mock ["a", "b", "c"] + assertEqual "Should return first error" (Left "error in batch") 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 "stream error") + callback _ = modifyIORef ref (const ["should not be called" :: String]) + result <- stream mock "test" callback + readRef <- readIORef ref + assertEqual "Stream should return error" (Left "stream error") result + assertEqual "Callback not called" [] readRef + ] diff --git a/test/Test/Langchain/Runnable/Utils.hs b/test/Test/Langchain/Runnable/Utils.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Runnable/Utils.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Langchain.Runnable.Utils (tests) where + +import Control.Concurrent (threadDelay) +import Data.IORef (IORef, modifyIORef, newIORef, readIORef) +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 String 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 "Error" + 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 "Error") + retryMock = Retry mock 2 1000 -- 2 retries + result <- invoke retryMock ("input" :: String) + cnt <- readIORef counter + assertEqual "All retries exhausted" (Left "Error" :: Either String 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 "Operation timed out" :: Either String String) result + ] + ] + +data MockRunnable a b = MockRunnable {runMock :: a -> IO (Either String 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/TextSplitter/Character.hs b/test/Test/Langchain/TextSplitter/Character.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/TextSplitter/Character.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.TextSplitter.Character (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.TextSplitter.Character + +tests :: TestTree +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" $ + 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 + @?= [ "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"] + ] diff --git a/test/Test/Langchain/Tool/Core.hs b/test/Test/Langchain/Tool/Core.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Tool/Core.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Langchain.Tool.Core (tests) where + +import Data.Aeson (decode) +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.Core +import Langchain.Tool.WebScraper +import Langchain.Tool.WikipediaTool + +data 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 + ] + +testWebScraperTool :: Assertion +testWebScraperTool = do + r <- runTool WebScraper "https://hackage.haskell.org/package/scalpel-0.6.2.2" + assertBool "Scraper should contain stuff like title" $ + T.isInfixOf "scalpel: A high level web scraping library for Haskell" 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/VectorStore/Core.hs b/test/Test/Langchain/VectorStore/Core.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/VectorStore/Core.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.VectorStore.Core (tests) where + +import Data.Either (fromRight, isRight) +import Data.Int (Int64) +import Data.Map (empty) +import qualified Data.Map.Strict as Map +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 +import Langchain.VectorStore.InMemory + +data MockEmbeddings = MockEmbeddings + 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] + + embedDocuments _ docs = pure $ Right $ map determineEmbedding docs + where + determineEmbedding doc + | doc == Document "Hello World" empty = [1.0, 0.1, 0.1] + | doc == Document "Nice to meet you" empty = [0.1, 0.1, 1.0] + | doc == Document "Something completely different" empty = [0.3, 0.3, 0.3] + | otherwise = [0.0, 0.0, 0.0] + +createTestDocs :: [Document] +createTestDocs = + [ Document "Hello World" empty + , Document "Nice to meet you" empty + ] + +utilityTests :: TestTree +utilityTests = + testGroup + "Utility Functions Tests" + [ testCase "dotProduct should compute correct dot product" $ do + dotProduct [1.0, 2.0, 3.0] [4.0, 5.0, 6.0] @?= 32.0 + , testCase "norm should compute correct Euclidean norm" $ do + norm [3.0, 4.0] @?= 5.0 + , testCase "cosineSimilarity should compute correct similarity" $ do + assertBool + "Expected near same similarity" + ((cosineSimilarity [1.0, 2.0, 3.0] [1.0, 2.0, 3.0]) >= 0.999999) + + let similarity = cosineSimilarity [1.0, 0.0, 0.0] [0.0, 1.0, 0.0] + assertBool "Expected near 0" (abs similarity < 0.000001) + + let oppSimilarity = cosineSimilarity [1.0, 2.0, 3.0] [-1.0, -2.0, -3.0] + assertBool "Expected near -1" (abs (oppSimilarity + 1.0) < 0.000001) + ] + +inMemoryTests :: TestTree +inMemoryTests = + testGroup + "InMemory VectorStore Tests" + [ testCase "emptyInMemoryVectorStore should create empty store" $ do + let model = MockEmbeddings + vs = emptyInMemoryVectorStore model + Map.size (store vs) @?= 0 + embeddingModel vs @?= model + , testCase "fromDocuments should create store with documents" $ do + let model = MockEmbeddings + docs = createTestDocs + result <- fromDocuments model docs + assertBool "Expected Right result" (isRight result) + let vs = fromRight (emptyInMemoryVectorStore model) result + Map.size (store vs) @?= 2 + , testCase "addDocuments should add documents to store" $ do + let model = MockEmbeddings + vs = emptyInMemoryVectorStore model + docs = createTestDocs + result <- 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] + assertBool "Expected Right result" (isRight result2) + let finalVs = fromRight updatedVs result2 + Map.size (store finalVs) @?= 3 + , testCase "delete should remove documents from store" $ do + let model = MockEmbeddings + vs = emptyInMemoryVectorStore model + docs = createTestDocs + result <- addDocuments vs docs + let updatedVs = fromRight vs result + + deleteResult <- delete updatedVs [1] + assertBool "Expected Right result" (isRight deleteResult) + let afterDeleteVs = fromRight updatedVs deleteResult + Map.size (store afterDeleteVs) @?= 1 + Map.member (1 :: Int64) (store afterDeleteVs) @?= False + Map.member (2 :: Int64) (store afterDeleteVs) @?= True + , testCase "similaritySearch should find similar documents" $ do + 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 + 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 + 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 +tests = + testGroup + "Langchain.VectorStore Tests" + [ utilityTests + , inMemoryTests + ]