langchain-hs 0.0.1.0 → 0.0.2.0

raw patch · 39 files changed

+4087/−1644 lines, 39 filesdep +asyncdep +conduitdep +parsecdep −scalpeldep ~filepathdep ~ollama-haskelldep ~textPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: async, conduit, parsec, tagsoup, vector

Dependencies removed: scalpel

Dependency ranges changed: filepath, ollama-haskell, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +26/−2
• README.md +15/−13
• langchain-hs.cabal +32/−6
• src/Langchain/Agents/Core.hs +8/−130
• src/Langchain/Agents/React.hs +87/−185
• src/Langchain/Chain/RetrievalQA.hs +78/−0
• src/Langchain/DocumentLoader/Core.hs +1/−0
• src/Langchain/DocumentLoader/DirectoryLoader.hs +159/−0
• src/Langchain/DocumentLoader/PdfLoader.hs +5/−10
• src/Langchain/Embeddings/Core.hs +8/−19
• src/Langchain/Embeddings/Ollama.hs +5/−19
• src/Langchain/Embeddings/OpenAI.hs +237/−0
• src/Langchain/LLM/Core.hs +17/−85
• src/Langchain/LLM/Huggingface.hs +231/−0
• src/Langchain/LLM/Internal/Huggingface.hs +686/−0
• src/Langchain/LLM/Internal/OpenAI.hs +1149/−0
• src/Langchain/LLM/Ollama.hs +77/−10
• src/Langchain/LLM/OpenAI.hs +338/−870
• src/Langchain/Memory/Core.hs +24/−19
• src/Langchain/Memory/TokenBufferMemory.hs +90/−0
• src/Langchain/OutputParser/Core.hs +1/−1
• src/Langchain/Runnable/ConversationChain.hs +2/−0
• src/Langchain/Runnable/Core.hs +0/−1
• src/Langchain/Tool/Calculator.hs +113/−0
• src/Langchain/Tool/Core.hs +1/−1
• src/Langchain/Tool/Utils.hs +98/−0
• src/Langchain/Tool/WebScraper.hs +26/−50
• src/Langchain/Tool/WikipediaTool.hs +3/−2
• test/Spec.hs +6/−2
• test/Test/Langchain/Agent/ReactAgent.hs +0/−134
• test/Test/Langchain/DocumentLoader/DirectoryLoader.hs +249/−0
• test/Test/Langchain/Embeddings/Core.hs +1/−56
• test/Test/Langchain/LLM/Core.hs +15/−24
• test/Test/Langchain/LLM/Ollama.hs +74/−1
• test/Test/Langchain/Memory/Core.hs +1/−1
• test/Test/Langchain/Memory/TokenBufferMemory.hs +131/−0
• test/Test/Langchain/Retriever/Core.hs +2/−0
• test/Test/Langchain/Runnable/ConversationChains.hs +2/−0
• test/Test/Langchain/Tool/Core.hs +89/−3

@@ -1,4 +1,4 @@-# Changelog for `langchain-haskell`+# Changelog for `langchain-hs`  All notable changes to this project will be documented in this file. @@ -8,4 +8,28 @@  ## Unreleased -## 0.1.0.0 - YYYY-MM-DD+## 0.0.2.0 - 2025-05-04++### Added++- Added `OpenAI` LLM integration.+- Added `DirectoryLoader` for loading Documents from a directory.+- Added `HuggingFace` LLM integration.+- Added docusaurus documentation.+- Added `OpenAI` embeddings integration.+- Added GHC CI matrix build.+- Added `TokenBufferMemory` Memory integration.+- Added `RetrievalQA` chain.+- Added `CalculatorTool` tool.++### Fixed ++- Fixed `loadAndSplit` function for `PdfLoader`.+- Minor documentation fixes.+- Fixed `WebScraper` to only scrape textual content.+- Made langchain-hs buildable till stack-lts-19.33+- Fixed `React` agent.++### Changed++- Generalized LLMParams to accept different type per LLM. 

@@ -2,10 +2,18 @@  ⚡ Building applications with LLMs through composability in Haskell! ⚡ +<div style="text-align: center;">+<img src="./docs/static/img/langchain_haskell.jpg" alt="logo image" height="300"/>+</div>+ ## 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. +### [Documentation](https://tusharad.github.io/langchain-hs/docs/)+### [Hackage API reference](https://hackage.haskell.org/package/langchain-hs)++ ## Features  - **LLM Integration**: Seamlessly interact with various language models, including OpenAI's GPT series and others.@@ -13,10 +21,16 @@ - **Memory Management**: Implement conversational memory to maintain context across interactions. - **Agents and Tools**: Develop agents that can utilize tools to perform complex tasks. - **Document Loaders**: Load and process documents from various sources for use in your applications.+- **Text Splitter**: Components for splitting text into smaller chunks for processing.+- **Output Parser**: Components for parsing and processing the output of LLMs.+- **VectorStore and Retriever**: Mechanism for storing and retrieving document embeddings.+- **Embeddings**: Components for generating vector representations of text.  ## Current Supported Providers    - Ollama+  - OpenAI+  - Huggingface   - More to come...  ## Installation@@ -26,7 +40,7 @@  ```yaml dependencies:-  - base >= 4.7 && < 5+  - base < 5   - langchain-hs ``` Then, run the build command for your respective build tool to fetch and compile the dependency.@@ -60,18 +74,6 @@         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 

@@ -5,10 +5,10 @@ -- see: https://github.com/sol/hpack  name:           langchain-hs-version:        0.0.1.0+version:        0.0.2.0 synopsis:       Haskell implementation of Langchain description:    Build LLM-powered applications in Haskell.-category:       Web+category:       Web, AI homepage:       https://github.com/tusharad/langchain-hs#readme bug-reports:    https://github.com/tusharad/langchain-hs/issues author:         tushar@@ -17,6 +17,13 @@ license:        MIT license-file:   LICENSE build-type:     Simple+tested-with:+    GHC == 9.10.1+  , GHC == 9.8.4+  , GHC == 9.6.6+  , GHC == 9.4.8+  , GHC == 9.2.8+  , GHC == 9.0.2 extra-source-files:     README.md     CHANGELOG.md@@ -30,15 +37,22 @@       Langchain.Agents.Core       Langchain.Agents.React       Langchain.Callback+      Langchain.Chain.RetrievalQA       Langchain.DocumentLoader.Core+      Langchain.DocumentLoader.DirectoryLoader       Langchain.DocumentLoader.FileLoader       Langchain.DocumentLoader.PdfLoader       Langchain.Embeddings.Core       Langchain.Embeddings.Ollama+      Langchain.Embeddings.OpenAI       Langchain.LLM.Core+      Langchain.LLM.Huggingface+      Langchain.LLM.Internal.Huggingface+      Langchain.LLM.Internal.OpenAI       Langchain.LLM.Ollama       Langchain.LLM.OpenAI       Langchain.Memory.Core+      Langchain.Memory.TokenBufferMemory       Langchain.OutputParser.Core       Langchain.PromptTemplate       Langchain.Retriever.Core@@ -48,7 +62,9 @@       Langchain.Runnable.Core       Langchain.Runnable.Utils       Langchain.TextSplitter.Character+      Langchain.Tool.Calculator       Langchain.Tool.Core+      Langchain.Tool.Utils       Langchain.Tool.WebScraper       Langchain.Tool.WikipediaTool       Langchain.VectorStore.Core@@ -60,16 +76,21 @@   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints   build-depends:       aeson ==2.*+    , async <3     , base >=4.7 && <5     , bytestring >=0.10+    , conduit >=1.2 && <1.4     , containers >=0.6 && <0.9     , directory >=1.3.6 && <1.4+    , filepath <2     , http-conduit ==2.*     , http-types >=0.11 && <0.13     , ollama-haskell+    , parsec <4     , pdf-toolbox-document ==0.1.4-    , scalpel ==0.6.*-    , text ==2.*+    , tagsoup <0.15+    , text >=1.2 && <3+    , vector <0.14   default-language: Haskell2010  test-suite langchain-hs-test@@ -77,12 +98,13 @@   main-is: Spec.hs   other-modules:       Test.Langchain.Agent.Core-      Test.Langchain.Agent.ReactAgent       Test.Langchain.DocumentLoader.Core+      Test.Langchain.DocumentLoader.DirectoryLoader       Test.Langchain.Embeddings.Core       Test.Langchain.LLM.Core       Test.Langchain.LLM.Ollama       Test.Langchain.Memory.Core+      Test.Langchain.Memory.TokenBufferMemory       Test.Langchain.OutputParser.Core       Test.Langchain.PromptTemplate       Test.Langchain.Retriever.Core@@ -99,8 +121,10 @@   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N   build-depends:       aeson ==2.*+    , async <3     , base >=4.7 && <5     , bytestring >=0.10+    , conduit >=1.2 && <1.4     , containers >=0.6 && <0.9     , directory >=1.3.6 && <1.4     , filepath@@ -108,10 +132,12 @@     , http-types >=0.11 && <0.13     , langchain-hs     , ollama-haskell+    , parsec <4     , pdf-toolbox-document ==0.1.4-    , scalpel ==0.6.*+    , tagsoup <0.15     , tasty     , tasty-hunit     , temporary     , text+    , vector <0.14   default-language: Haskell2010

@@ -1,8 +1,5 @@-{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}  {- | Module      : Langchain.Agents.Core@@ -11,19 +8,7 @@ License     : MIT Maintainer  : Tushar Adhatrao <tusharadhatrao@gmail.com> -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"+Agents use LLMs as reasoning engines to determine actions dynamically.  -} module Langchain.Agents.Core   ( AgentAction (..)@@ -32,10 +17,8 @@   , Agent (..)   , AnyTool (..)   , AgentState (..)-  , AgentExecutor (..)   , runAgent   , runAgentLoop-  , runAgentExecutor   , executeTool   , runSingleStep   , customAnyTool@@ -49,7 +32,6 @@ 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 (..))  {- |@@ -87,72 +69,23 @@   }   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)--}+-- | A type that helps various types of Tools+-- It encapsulates the Tool, and conversion functions +-- to and from Text for Tool input and output since Agent takes and returns Text. +-- If Tool takes or returns Text type itself you can use `id` at these places. 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--}+-- | Typeclass for Agent 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--}+-- | Function that *starts* the agent process. runAgent :: (Agent a, BaseMemory m) => a -> AgentState m -> Text -> IO (Either String AgentFinish) runAgent agent initialState@AgentState {..} initialInput = do   memWithInput <- addUserMessage agentMemory initialInput@@ -199,15 +132,9 @@ {- | 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 =+executeTool tools toolName_ input = do   case find (\(AnyTool t _ _) -> toolName t == toolName_) tools of     Nothing -> return $ Left $ "Tool not found: " <> T.unpack toolName_     Just (AnyTool {..}) -> do@@ -222,55 +149,6 @@ {- | 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

@@ -1,40 +1,22 @@-{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}  {- | Module      : Langchain.Agents.React-Description : Implementation of ReAct agent combining reasoning and action+Description : Implementation of ReAct logic Copyright   : (c) 2025 Tushar Adhatrao License     : MIT Maintainer  : Tushar Adhatrao <tusharadhatrao@gmail.com> -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+ReAct forces LLM to reflect on your question and injects responses as if LLM figured them out by itself. +This allows you to connect any datasource or tool tou your LLM. -} module Langchain.Agents.React-  ( ReactAgentOutputParser (..)-  , parseReactOutput+  ( defaultReactPromptTemplate+  , runReactAgent   , 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@@ -45,21 +27,28 @@ 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:+-- | Default system prompt for React Agent+defaultReactPromptTemplate :: PromptTemplate+defaultReactPromptTemplate =+  PromptTemplate $+    T.unlines+      [ "You are an AI assistant designed to help with tasks."+      , "You have access to the following tools:"+      , "{tools}"+      , ""+      , "If you don't know the answer, you can use tool to get the information."+      , "Response in either one or the other format:"+      , "1. If you don't the answer and want to make a tool call:"+      , "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"+      , "... (this Thought/Action/Action Input can repeat N times)"+      , ""+      , "2. If you found out the answer:"+      , "Thought: I now know the final answer"+      , "Final Answer: the final answer to the original input question"+      ] -> parseReactOutput "Final Answer: 42"-> -- Right (Finish ...)->-> parseReactOutput "Action: calculator\nAction Input: 5+3"-> -- Right (Continue ...)--} newtype ReactAgentOutputParser = ReactAgentOutputParser AgentStep  instance OutputParser ReactAgentOutputParser where@@ -80,9 +69,15 @@                   }   | 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+      let actionName =+            extractAfter "Action:" $+              T.takeWhile (/= '\n') $+                T.dropWhile (/= 'A') text           actionInput_ =-            extractAfter "Action Input:" $ T.takeWhile (/= '\n') $ snd $ T.breakOn "Action Input:" text+            extractAfter "Action Input:" $+              T.takeWhile (/= '\n') $+                snd $+                  T.breakOn "Action Input:" text        in Right $             ReactAgentOutputParser $               Continue $@@ -93,168 +88,75 @@                   }   | 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+        else T.strip $ T.drop 2 $ T.dropWhile (/= ':') afterMarker -Example prompt excerpt:+-- | ReactAgent Type+data (LLM llm) => ReactAgent llm = ReactAgent+  { reactLLM :: llm+  , reactLLMParams :: Maybe (LLMParams llm)+  , reactToolList :: [AnyTool]+  } -> "Use the following format:-> Thought: ...-> Action: [tool_name]-> Action Input: ..."--}-createReactAgent ::-  (LLM llm) =>+-- | Run React Agent+runReactAgent ::+  LLM llm =>   llm ->+  Maybe (LLMParams 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:+  Text ->+  IO (Either String AgentFinish)+runReactAgent l mbParams tools userQuery = do+  let promptVars =+        Map.fromList+          [ ("tools", formatTools tools)+          , ("tool_names", formatToolNames tools)+          ]+  case renderPrompt defaultReactPromptTemplate promptVars of+    Left err -> pure $ Left err+    Right r -> do+      let reactAgent =+            ReactAgent+              { reactLLM = l+              , reactLLMParams = mbParams+              , reactToolList = tools+              }+      let windowMem = WindowBufferMemory 10 (initialChatMessage r)+      let agentState =+            AgentState+              { agentMemory = windowMem+              , agentToolResults = []+              , agentSteps = []+              }+      runAgent reactAgent agentState userQuery -> "Tool: wikipedia->  Description: Search Wikipedia..."--}-formatToolDescriptions :: [AnyTool] -> Text-formatToolDescriptions tools = T.intercalate "\n\n" $ map formatTool tools+formatTools :: [AnyTool] -> Text+formatTools 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:+instance (LLM llm) => Agent (ReactAgent llm) where+  planNextAction ReactAgent {..} AgentState {..} = do+    eMsgs <- messages agentMemory+    case eMsgs of+      Left err -> pure $ Left err+      Right msgs -> do+        eResponse <- chat reactLLM msgs reactLLMParams+        case eResponse of+          Left err -> pure $ Left err+          Right response -> do+            case parse response of+              Left err -> pure (Left $ "Failed to parse response " <> err <> show response)+              Right (ReactAgentOutputParser step) -> return $ Right step -- 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+  agentPrompt _ = pure $ PromptTemplate ""+  agentTools ReactAgent {..} = pure reactToolList

@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}++{- |+Module      : Langchain.Chain.RetrievalQA+Description : Chain for question-answering against an index.+Copyright   : (c) 2025 Tushar Adhatrao+License     : MIT+Maintainer  : Tushar Adhatrao <tusharadhatrao@gmail.com>++Haskell implementation of RetrievalQA.+-}+module Langchain.Chain.RetrievalQA+  ( RetrievalQA (..)+  , defaultQAPrompt+  ) where++import qualified Data.List.NonEmpty as NE+import Data.Map.Strict (fromList)+import Data.Text (Text)+import qualified Data.Text as T+import Langchain.DocumentLoader.Core (Document (..))+import Langchain.LLM.Core+import Langchain.PromptTemplate (PromptTemplate (..), renderPrompt)+import Langchain.Retriever.Core (Retriever (_get_relevant_documents))+import Langchain.Runnable.Core (Runnable (..))++-- | QA Chain that combines retrieval and LLM response generation.+data RetrievalQA llm retriever = RetrievalQA+  { llm :: llm+  , llmParams :: Maybe (LLMParams llm)+  , retriever :: retriever+  , prompt :: PromptTemplate+  }++-- | Creates a default QA prompt with context and question placeholders.+defaultQAPrompt :: PromptTemplate+defaultQAPrompt =+  PromptTemplate+    ( "Use the given context to answer the question. "+        <> "If you don't know the answer, say you don't know. "+        <> "Use three sentence maximum and keep the answer concise. "+        <> "Context: {context}"+    )++-- | Make RetrievalQA an instance of Runnable to allow composition.+instance (LLM llm, Retriever retriever) => Runnable (RetrievalQA llm retriever) where+  type RunnableInput (RetrievalQA llm retriever) = Text+  type RunnableOutput (RetrievalQA llm retriever) = Text++  invoke RetrievalQA {..} question = do+    -- Retrieve relevant documents+    docResult <- _get_relevant_documents retriever question+    case docResult of+      Left err -> return $ Left err+      Right docs -> do+        let context = T.intercalate "\n\n" $ map (\(Document c _) -> c) docs+        let vars = [("context", context)]++        -- Render prompt with context and question+        renderedPrompt <- case renderPrompt prompt (fromList vars) of+          Left e -> return $ Left e+          Right r -> return $ Right r++        case renderedPrompt of+          Left e -> return $ Left e+          Right finalPrompt -> do+            let chatConvo =+                  NE.fromList+                    [ Message System finalPrompt defaultMessageData+                    , Message User question defaultMessageData+                    ]+            -- Get LLM response+            llmResponse <- chat llm chatConvo llmParams+            case llmResponse of+              Left e -> return $ Left e+              Right answer -> return $ Right answer

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} {- | Module      : Langchain.DocumentLoader.Core Description : Core document loading functionality for LangChain Haskell

@@ -0,0 +1,159 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++{- |+Module      : Langchain.DocumentLoader.DirectoryLoader+Description : Directory loading implementation for LangChain Haskell+Copyright   : (c) 2025 Tushar Adhatrao+License     : MIT+Maintainer  : Tushar Adhatrao <tusharadhatrao@gmail.com>+Stability   : experimental++DirectoryLoader document loader implements functionality for reading files from disk into Documents+-}+module Langchain.DocumentLoader.DirectoryLoader+  ( +    -- * Directory loader+    DirectoryLoader (..)+  , DirectoryLoaderOptions (..)+    -- * Default functions+  , defaultDirectoryLoaderOptions+  ) where++import Control.Concurrent.Async (mapConcurrently)+import Control.Monad (filterM)+import Data.Maybe (listToMaybe)+import Langchain.DocumentLoader.Core+import Langchain.DocumentLoader.FileLoader (FileLoader (FileLoader))+import Langchain.DocumentLoader.PdfLoader (PdfLoader (PdfLoader))+import Langchain.TextSplitter.Character+import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)+import System.FilePath (takeFileName, takeExtension, (</>))++-- | Options for directory loading behavior+data DirectoryLoaderOptions = DirectoryLoaderOptions+  { recursiveDepth :: Maybe Int+  -- ^ Nothing = unlimited depth, Just 0 = No recursive, Just 3 = 3 level deep+  , extensions :: [String]+  -- ^ File extensions to include (e.g., [".txt", ".md"])+  , excludeHidden :: Bool+  -- ^ Whether to exclude hidden files (starting with '.')+  , useMultithreading :: Bool+  -- ^ Whether to use multithreading when loading files+  }+  deriving (Eq, Show)++-- | Default directory loader options+defaultDirectoryLoaderOptions :: DirectoryLoaderOptions+defaultDirectoryLoaderOptions =+  DirectoryLoaderOptions+    { recursiveDepth = Nothing+    , extensions = [] -- Empty list means all files+    , excludeHidden = True+    , useMultithreading = False+    }++{- | Directory loader configuration+Specifies the path to load documents from.++Example:++>>> DirectoryLoader "langchain-hs/src" defaultDirectoryLoaderOptions+-}+data DirectoryLoader = DirectoryLoader+  { dirPath :: FilePath+  , directoryLoaderOptions :: DirectoryLoaderOptions+  }+  deriving (Eq, Show)++-- | Helper to check if a file should be included based on options+shouldIncludeFile :: DirectoryLoaderOptions -> FilePath -> Bool+shouldIncludeFile opts path =+  let ext = takeExtension path+      fName = takeFileName path+      isHidden = if listToMaybe fName == Just '.' then True else False+      matchesExt = null (extensions opts) || ext `elem` extensions opts+      passesHiddenCheck = not (excludeHidden opts) || not isHidden+   in matchesExt && passesHiddenCheck++-- | Get all files in a directory, with controlled recursion+getFilesInDirectory :: DirectoryLoaderOptions -> Int -> FilePath -> IO [FilePath]+getFilesInDirectory opts currentDepth dir = do+  -- Check if we've reached max depth (if specified)+  let canRecurse = case recursiveDepth opts of+        Nothing -> True+        Just maxD -> currentDepth < maxD++  entries <- listDirectory dir+  let fullPaths = map (dir </>) entries++  -- Find all files in current directory+  files <- filterM doesFileExist fullPaths+  let filteredFiles = filter (shouldIncludeFile opts) files++  -- If we can recurse deeper and recursion is enabled, process subdirectories+  subFiles <-+    if canRecurse+      then do+        subdirs <- filterM doesDirectoryExist fullPaths+        -- Skip hidden directories if excludeHidden is set+        let visibleSubdirs =+              if excludeHidden opts+                then filter (\d -> not (null d) && last d /= '.') subdirs+                else subdirs++        -- Process subdirectories (potentially in parallel)+        if useMultithreading opts && not (null visibleSubdirs)+          then concat <$> mapConcurrently (getFilesInDirectory opts (currentDepth + 1)) visibleSubdirs+          else concat <$> mapM (getFilesInDirectory opts (currentDepth + 1)) visibleSubdirs+      else return []++  return $ filteredFiles ++ subFiles++loadFileToDocument :: FilePath -> IO (Either String [Document])+loadFileToDocument path = do+  exists <- doesFileExist path+  if not exists+    then return $ Left $ "File does not exist: " ++ path+    else do+      -- if file is pdf then read it using PdfLoader else use fileLoader+      if takeExtension path == ".pdf"+        then+          load (PdfLoader path)+        else+          load (FileLoader path)++instance BaseLoader DirectoryLoader where+  load DirectoryLoader {..} = do+    exists <- doesDirectoryExist dirPath+    if exists+      then do+        filePaths <- getFilesInDirectory directoryLoaderOptions 0 dirPath+        -- Process files (using multithreading if enabled)+        docs <-+          if useMultithreading directoryLoaderOptions && not (null filePaths)+            then mapConcurrently loadFileToDocument filePaths+            else mapM loadFileToDocument filePaths+        -- Separate successes and failures+        let (errors, documents) = foldr separateResults ([], []) docs++        -- Return documents or combined error message+        case errors of+          [] -> return $ Right documents+          _ -> return $ Left $ unlines errors+      else+        return $ Left $ "Directory does not exist: " ++ dirPath+    where+      separateResults (Left err) (errs, docs) = (err : errs, docs)+      separateResults (Right doc) (errs, docs) = (errs, doc <> docs)++  loadAndSplit dirLoader = do+    eRes <- load dirLoader+    case eRes of+      Left e -> pure $ Left e+      Right documents ->+        pure $+          Right $+            splitText+              defaultCharacterSplitterOps+              (pageContent $ mconcat documents)

@@ -8,11 +8,7 @@ Maintainer  : Tushar Adhatrao <tusharadhatrao@gmail.com> 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.+This module provides a loader for loading PDF files.  -} module Langchain.DocumentLoader.PdfLoader   ( PdfLoader (..)@@ -20,7 +16,6 @@  import Data.Aeson import Data.Map (fromList)-import Data.Text (pack) import Langchain.DocumentLoader.Core import Langchain.TextSplitter.Character import Pdf.Document hiding (Document)@@ -90,9 +85,9 @@         return $ Left $ "File not found: " ++ path    -- \|-  --  Loads the raw content of the PDF file and splits it using a recursive character splitter.+  --  Loads the raw content of the PDF file and splits it using a character splitter.   ---  --  This method reads the entire file as text (without parsing its PDF structure) and applies+  --  This method reads the entire pdf as text and applies   --  'splitText' with default recursive character options to divide the text into chunks.   --  This approach is useful when only a simple text split is required rather than structured   --  page extraction.@@ -104,7 +99,7 @@     exists <- doesFileExist path     if exists       then do-        content <- readFile path-        return $ Right $ splitText defaultCharacterSplitterOps (pack content)+        documents <- readPdf path+        return $ Right $ splitText defaultCharacterSplitterOps (pageContent $ mconcat documents)       else         return $ Left $ "File not found: " ++ path

@@ -15,25 +15,14 @@ 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+  let oEmbed = defaultOpenAIEmbeddings { apiKey = "api-key" }+  let p = PdfLoader "/home/user/Documents/TS/langchain/SOP.pdf"+  eDocs <- load p+  case eDocs of+    Left err -> error err+    Right docs -> do+      eRes <- embedQuery oEmbed "Hello"+      print eRes @ -} module Langchain.Embeddings.Core

@@ -16,7 +16,7 @@ @ -- Create Ollama embeddings configuration ollamaEmb = OllamaEmbeddings-  { model = "llama3"+  { model = "nomic-embed-text:latest"   , defaultTruncate = Just True   , defaultKeepAlive = Just "5m"   }@@ -69,23 +69,6 @@     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.@@ -97,7 +80,10 @@   --   embedDocuments (OllamaEmbeddings {..}) docs = do     -- For each input text, make an individual API call-    results <- mapM (\doc -> embeddingOps model (pageContent doc) defaultTruncate defaultKeepAlive) docs+    results <-+      mapM+        (\doc -> embeddingOps model (pageContent doc) defaultTruncate defaultKeepAlive)+        docs     -- Combine the results, handling errors appropriately     return $       sequence results >>= \resps ->

@@ -0,0 +1,237 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++{- |+Module      : Langchain.Embeddings.OpenAI+Description : OpenAI integration for text embeddings in LangChain Haskell+Copyright   : (c) 2025 Tushar Adhatrao+License     : MIT+Maintainer  : Tushar Adhatrao <tusharadhatrao@gmail.com>+Stability   : experimental++OpenAI implementation of LangChain's embedding interface. Supports document and query+embedding generation through OpenAI's API.+Checkout docs here: https://platform.openai.com/docs/guides/embeddings+-}+module Langchain.Embeddings.OpenAI+  ( -- * Types+    OpenAIEmbeddings (..)++    -- * Helper model name functions+  , defaultOpenAIEmbeddings+  , textEmbedding3Small+  , textEmbedding3Large+  , textEmbeddingAda+  ) where++{-+  No need to expose these, but can be expose later for direct use+  -- * Request Types+  OpenAIEmbeddingsRequest (..)+, EmbeddingsInput (..)+, EncodingFormat (..)++  -- * ResponseTypes+, OpenAIEmbeddingsResponse (..)+, EmbeddingsObject (..)+, EmbeddingsUsage (..)+-}++import Data.Aeson+import Data.Maybe+import Data.Text (Text, unpack)+import Data.Text.Encoding (encodeUtf8)+import qualified Data.Vector as V+import GHC.Generics+import Langchain.DocumentLoader.Core+import Langchain.Embeddings.Core+import Network.HTTP.Conduit+import Network.HTTP.Simple+  ( getResponseBody+  , getResponseStatus+  , setRequestBodyJSON+  , setRequestHeader+  , setRequestMethod+  , setRequestSecure+  )+import Network.HTTP.Types.Status (statusCode)++-- Internal types for serialization of OpenAI request.+data EncodingFormat = FloatFormat | Base64Format+  deriving (Eq, Show, Generic)++data EmbeddingsInput = TextInput Text | TextList [Text]+  deriving (Show, Eq)++data OpenAIEmbeddingsRequest = OpenAIEmbeddingsRequest+  { inputReq :: EmbeddingsInput+  , modelReq :: Text+  , dimensionsReq :: Maybe Int+  -- ^ Only supported in text-embedding-3 or later+  , encodingFormatReq :: Maybe EncodingFormat+  , embeddingsUserReq :: Maybe Text+  }+  deriving (Show, Eq, Generic)++instance ToJSON EncodingFormat where+  toJSON FloatFormat = String "float"+  toJSON Base64Format = String "base64"++instance ToJSON EmbeddingsInput where+  toJSON (TextInput t) = String t+  toJSON (TextList t) = Array (V.fromList $ map String t)++instance ToJSON OpenAIEmbeddingsRequest where+  toJSON OpenAIEmbeddingsRequest {..} =+    object+      [ "input" .= inputReq+      , "model" .= modelReq+      , "dimensions" .= dimensionsReq+      , "encoding_format" .= encodingFormatReq+      , "user" .= embeddingsUserReq+      ]++-- Response+data EmbeddingsUsage = EmbeddingsUsage+  { promptTokens :: Int+  , totalTokens :: Int+  }+  deriving (Eq, Show, Generic)++data EmbeddingsObject = EmbeddingsObject+  { embeddings :: [Float]+  , index :: Int+  , objectType :: Text+  }+  deriving (Eq, Show, Generic)++data OpenAIEmbeddingsResponse = OpenAIEmbeddingsResponse+  { objectTypeResp :: Text+  , dataList :: [EmbeddingsObject]+  , responseModel :: Text+  , usage :: EmbeddingsUsage+  }+  deriving (Eq, Show, Generic)++instance FromJSON EmbeddingsUsage where+  parseJSON (Object v) =+    EmbeddingsUsage+      <$> v .: "prompt_tokens"+      <*> v .: "total_tokens"+  parseJSON _ = error "Parse error, expecting object"++instance FromJSON EmbeddingsObject where+  parseJSON (Object v) =+    EmbeddingsObject+      <$> v .: "embedding"+      <*> v .: "index"+      <*> v .: "object"+  parseJSON _ = error "Parse error, expecting object"++instance FromJSON OpenAIEmbeddingsResponse where+  parseJSON (Object v) =+    OpenAIEmbeddingsResponse+      <$> v .: "object"+      <*> v .: "data"+      <*> v .: "model"+      <*> v .: "usage"+  parseJSON _ = error "Parse error, expecting object"++-- | Embeddings type for OpenAI, can be used for embed documents with OpenAI.+data OpenAIEmbeddings = OpenAIEmbeddings+  { apiKey :: Text+  -- ^ OpenAI API Key+  , model :: Text+  -- ^ Model name for embeddings+  , dimensions :: Maybe Int+  -- ^ The number of dimensions the resulting output embeddings should have.+  -- ^ Only supported in text-embedding-3 or later+  , encodingFormat :: Maybe EncodingFormat+  -- ^ The format to return the embeddings in.+  -- ^ For now, only float is supported+  , embeddingsUser :: Maybe Text+  -- ^ A unique identifier representing your end-user, which can help OpenAI to monitor and detect abuse.+  , timeout :: Maybe Int+  -- ^ Override default responsetime out. unit = seconds.+  }+  deriving (Eq, Generic)++instance Show OpenAIEmbeddings where+  show OpenAIEmbeddings {..} = "OpenAIEmbeddings " <> "model " <> unpack model++openAIEmbeddingsRequest :: OpenAIEmbeddings -> [Text] -> IO (Either String OpenAIEmbeddingsResponse)+openAIEmbeddingsRequest OpenAIEmbeddings {..} txts = do+  request_ <- parseRequest "https://api.openai.com/v1/embeddings"+  manager <-+    newManager+      tlsManagerSettings+        { managerResponseTimeout =+            responseTimeoutMicro (fromMaybe 60 timeout * 1000000)+        }+  let req =+        setRequestMethod "POST"+          $ setRequestSecure True+          $ setRequestHeader "Content-Type" ["application/json"]+          $ setRequestHeader "Authorization" ["Bearer " <> encodeUtf8 apiKey]+          $ setRequestBodyJSON+            ( OpenAIEmbeddingsRequest+                { inputReq = TextList txts+                , modelReq = model+                , dimensionsReq = dimensions+                , encodingFormatReq = encodingFormat+                , embeddingsUserReq = embeddingsUser+                }+            )+          $ request_++  response <- httpLbs req manager+  let status = statusCode $ getResponseStatus response+  if status >= 200 && status < 300+    then case eitherDecode (getResponseBody response) of+      Left err -> return $ Left $ "JSON parse error: " <> err+      Right completionResponse -> return $ Right completionResponse+    else return $ Left $ "API error: " <> show status <> " " <> show (getResponseBody response)++instance Embeddings OpenAIEmbeddings where+  embedDocuments openAIEmbeddings docs = do+    eRes <- openAIEmbeddingsRequest openAIEmbeddings (map pageContent docs)+    case eRes of+      Left err -> pure $ Left err+      Right (OpenAIEmbeddingsResponse {..}) -> do+        pure $ Right $ map embeddings dataList++  embedQuery openAIEmbeddings query = do+    eRes <- openAIEmbeddingsRequest openAIEmbeddings [query]+    case eRes of+      Left err -> pure $ Left err+      Right (OpenAIEmbeddingsResponse {..}) -> do+        case listToMaybe dataList of+          Nothing -> pure $ Left "Embeddings are empty"+          Just x -> pure $ Right $ embeddings x++-- Helper functions, model name functions++-- | Small embedding model+textEmbedding3Small :: Text+textEmbedding3Small = "text-embedding-3-small"++-- | Most capable embedding model+textEmbedding3Large :: Text+textEmbedding3Large = "text-embedding-3-large"++-- | Older embedding model+textEmbeddingAda :: Text+textEmbeddingAda = "text-embedding-ada-002"++-- | Default values OpenAIEmbeddings, api-key is empty+defaultOpenAIEmbeddings :: OpenAIEmbeddings+defaultOpenAIEmbeddings =+  OpenAIEmbeddings+    { apiKey = ""+    , model = textEmbedding3Small+    , dimensions = Nothing+    , encodingFormat = Nothing+    , embeddingsUser = Nothing+    , timeout = Nothing+    }

@@ -1,12 +1,14 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RecordWildCards #-}  {- | Module:      Langchain.LLM.Core Copyright:   (c) 2025 Tushar Adhatrao License:     MIT+Description: Core implementation of langchain chat models Maintainer:  Tushar Adhatrao <tusharadhatrao@gmail.com> Stability:   experimental @@ -18,8 +20,10 @@ 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,++* Data types such as 'Message' for conversation messages,   and 'StreamHandler' for handling streaming responses.+ * Default values like 'defaultParams' and 'defaultMessageData' for convenience.  This module is intended to be used as the foundation for building applications that interact with LLMs,@@ -34,11 +38,9 @@   , Role (..)   , ChatMessage   , MessageData (..)-  , Params (..)   , StreamHandler (..)      -- * Default Values-  , defaultParams   , defaultMessageData   ) where @@ -47,35 +49,6 @@ 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.@@ -105,6 +78,10 @@     Assistant   | -- | Tool role, for tool outputs or interactions     Tool+  | Developer+    -- | Special role for developer messages. Specific to only some integrations+  | Function+    -- | Function call messages. Specific to only some integrations   deriving (Eq, Show, Generic, ToJSON, FromJSON)  {- | Represents a message in a conversation, including the sender's role, content,@@ -171,47 +148,17 @@     , 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-@--}+-- | Typeclass that all ChatModels should interface with class LLM m where-  -- | Invoke the language model with a single prompt.-  --        Suitable for simple queries; returns either an error or generated text.+  -- | Define the Parameter type for your LLM model.+  type LLMParams m -  {- === 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-  @--  -}+  -- | Invoke the language model with a single prompt.+  --        Suitable for simple queries; returns either an error or generated text.   generate :: m -- ^ The type of the language model instance.     -> Text -- ^ The prompt to send to the model.-    -> Maybe Params -- ^ Optional configuration parameters.+    -> Maybe (LLMParams m) -- ^ Optional configuration parameters.     -> IO (Either String Text)    -- | Chat with the language model using a sequence of messages.@@ -219,24 +166,9 @@   --   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.+    -> Maybe (LLMParams m) -- ^ 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-    }+  stream :: m -> ChatMessage -> StreamHandler -> Maybe (LLMParams m) -> IO (Either String ())

@@ -0,0 +1,231 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}++{- |+Module:      Langchain.LLM.Huggingface+Copyright:   (c) 2025 Tushar Adhatrao+License:     MIT+Maintainer:  Tushar Adhatrao <tusharadhatrao@gmail.com>+Stability:   experimental++Huggingface inference implementation Langchain's LLM Interface.+https://huggingface.co/docs/inference-providers/providers/cerebras++* Support for text generation, chat, and streaming responses+* Configuration of Huggingface-specific parameters (temperature, max tokens, etc.)+* Conversion between Langchain's message format and Huggingface's API requirements+* Compatibility with Huggingface's hosted inference API and other providers+-}+module Langchain.LLM.Huggingface+  ( -- * Types+    Huggingface (..)+  , Huggingface.Provider (..)+  , HuggingfaceParams (..)++    -- * Functions+  , defaultHuggingfaceParams+  , Huggingface.defaultMessage+  ) where++import qualified Data.List.NonEmpty as NE+import Data.Maybe+import Data.Text (Text, unpack)+import Langchain.Callback+import Langchain.LLM.Core as LLM+import qualified Langchain.LLM.Internal.Huggingface as Huggingface++-- | Configuration for Huggingface LLM integration+data Huggingface = Huggingface+  { provider :: Huggingface.Provider+  -- ^ Service provider (e.g., HostedInferenceAPI)+  , apiKey :: Text+  -- ^ Huggingface API authentication key+  , modelName :: Text+  -- ^ Model identifier (e.g., "google/flan-t5-xl")+  , callbacks :: [Callback]+  -- ^ Event handlers for inference lifecycle+  }++instance Show Huggingface where+  show Huggingface {..} =+    "Huggingface { provider = "+      <> show provider+      <> ", modelName = "+      <> unpack modelName+      <> " }"++-- | Generation parameters specific to Huggingface models+data HuggingfaceParams = HuggingfaceParams+  { frequencyPenalty :: Maybe Double+  -- ^ Penalty for token frequency (0.0-2.0)+  , maxTokens :: Maybe Integer+  -- ^ Token limit for output+  , presencePenalty :: Maybe Double+  -- ^ Penalty for token presence (0.0-2.0)+  , stop :: Maybe [String]+  -- ^ Stop sequences to terminate generation+  , toolPrompt :: Maybe String+  -- ^ Special prompt for tool interactions+  , topP :: Maybe Double+  -- ^ Nucleus sampling probability threshold+  , temperature :: Maybe Double+  -- ^ Sampling temperature (0.0-1.0)+  , timeout :: Maybe Int+  -- ^ Number of seconds for request timeout+  }+  deriving (Eq, Show)++-- | Default values for huggingface params+defaultHuggingfaceParams :: HuggingfaceParams+defaultHuggingfaceParams =+  HuggingfaceParams+    { frequencyPenalty = Nothing+    , maxTokens = Nothing+    , presencePenalty = Nothing+    , stop = Nothing+    , toolPrompt = Nothing+    , topP = Nothing+    , temperature = Nothing+    , timeout = Just 60+    }++instance LLM Huggingface where+  type LLMParams Huggingface = HuggingfaceParams++  generate Huggingface {..} prompt mbHuggingfaceParams = do+    eRes <-+      Huggingface.createChatCompletion+        apiKey+        Huggingface.defaultHuggingfaceChatCompletionRequest+          { Huggingface.provider = provider+          , Huggingface.messages =+              [Huggingface.defaultMessage {Huggingface.content = Huggingface.TextContent prompt}]+          , Huggingface.model = modelName+          , Huggingface.stream = False+          , Huggingface.maxTokens = maybe Nothing maxTokens mbHuggingfaceParams+          , Huggingface.frequencyPenalty = maybe Nothing frequencyPenalty mbHuggingfaceParams+          , -- , Huggingface.logProbs = maybe Nothing logProbs mbHuggingfaceParams+            Huggingface.presencePenalty = maybe Nothing presencePenalty mbHuggingfaceParams+          , -- , Huggingface.seed = maybe Nothing seed mbHuggingfaceParams+            Huggingface.stop = maybe Nothing stop mbHuggingfaceParams+          , Huggingface.temperature = maybe Nothing temperature mbHuggingfaceParams+          , -- , Huggingface.toolPrompt = maybe Nothing toolPrompt mbHuggingfaceParams+            -- , Huggingface.topLogprobs = maybe Nothing topLogProbs mbHuggingfaceParams+            Huggingface.topP = maybe Nothing topP mbHuggingfaceParams+          , Huggingface.timeout = maybe Nothing timeout mbHuggingfaceParams+          -- , Huggingface.streamOptions = maybe Nothing streamOptions mbHuggingfaceParams+          -- , Huggingface.responseFormat = maybe Nothing responseFormat mbHuggingfaceParams+          -- , Huggingface.tools = maybe Nothing tools mbHuggingfaceParams+          -- , Huggingface.toolChoice = maybe Nothing toolChoice mbHuggingfaceParams+          }+    case eRes of+      Left err -> return $ Left err+      Right r -> do+        case listToMaybe ((\Huggingface.ChatCompletionResponse {..} -> choices) r) of+          Nothing -> return $ Left "Did not received any response"+          Just resp ->+            let Huggingface.Message {..} = Huggingface.message resp+             in pure $+                  Right $+                    ( \c -> case c of+                        Huggingface.TextContent t -> t+                        _ -> ""+                    )+                      content++  chat Huggingface {..} msgs mbHuggingfaceParams = do+    eRes <-+      Huggingface.createChatCompletion+        apiKey+        Huggingface.defaultHuggingfaceChatCompletionRequest+          { Huggingface.provider = provider+          , Huggingface.messages = toHuggingfaceMessages msgs+          , Huggingface.model = modelName+          , Huggingface.stream = False+          , Huggingface.maxTokens = maybe Nothing maxTokens mbHuggingfaceParams+          , Huggingface.frequencyPenalty = maybe Nothing frequencyPenalty mbHuggingfaceParams+          , -- , Huggingface.logProbs = maybe Nothing logProbs mbHuggingfaceParams+            Huggingface.presencePenalty = maybe Nothing presencePenalty mbHuggingfaceParams+          , -- , Huggingface.seed = maybe Nothing seed mbHuggingfaceParams+            Huggingface.stop = maybe Nothing stop mbHuggingfaceParams+          , Huggingface.temperature = maybe Nothing temperature mbHuggingfaceParams+          , -- , Huggingface.toolPrompt = maybe Nothing toolPrompt mbHuggingfaceParams+            -- , Huggingface.topLogprobs = maybe Nothing topLogProbs mbHuggingfaceParams+            Huggingface.topP = maybe Nothing topP mbHuggingfaceParams+          , Huggingface.timeout = maybe Nothing timeout mbHuggingfaceParams+          -- , Huggingface.streamOptions = maybe Nothing streamOptions mbHuggingfaceParams+          -- , Huggingface.responseFormat = maybe Nothing responseFormat mbHuggingfaceParams+          -- , Huggingface.tools = maybe Nothing tools mbHuggingfaceParams+          -- , Huggingface.toolChoice = maybe Nothing toolChoice mbHuggingfaceParams+          }+    case eRes of+      Left err -> return $ Left err+      Right r -> do+        case listToMaybe ((\Huggingface.ChatCompletionResponse {..} -> choices) r) of+          Nothing -> return $ Left "Did not received any response"+          Just resp ->+            let Huggingface.Message {..} = Huggingface.message resp+             in pure $+                  Right $+                    ( \c -> case c of+                        Huggingface.TextContent t -> t+                        _ -> ""+                    )+                      content++  stream Huggingface {..} msgs LLM.StreamHandler {..} mbHuggingfaceParams = do+    Huggingface.createChatCompletionStream+      apiKey+      Huggingface.defaultHuggingfaceChatCompletionRequest+        { Huggingface.provider = provider+        , Huggingface.messages = toHuggingfaceMessages msgs+        , Huggingface.model = modelName+        , Huggingface.stream = True+        , Huggingface.maxTokens = maybe Nothing maxTokens mbHuggingfaceParams+        , Huggingface.frequencyPenalty = maybe Nothing frequencyPenalty mbHuggingfaceParams+        , -- , Huggingface.logProbs = maybe Nothing logProbs mbHuggingfaceParams+          Huggingface.presencePenalty = maybe Nothing presencePenalty mbHuggingfaceParams+        , -- , Huggingface.seed = maybe Nothing seed mbHuggingfaceParams+          Huggingface.stop = maybe Nothing stop mbHuggingfaceParams+        , Huggingface.temperature = maybe Nothing temperature mbHuggingfaceParams+        , -- , Huggingface.toolPrompt = maybe Nothing toolPrompt mbHuggingfaceParams+          -- , Huggingface.topLogprobs = maybe Nothing topLogProbs mbHuggingfaceParams+          Huggingface.topP = maybe Nothing topP mbHuggingfaceParams+        , Huggingface.timeout = maybe Nothing timeout mbHuggingfaceParams+        -- , Huggingface.streamOptions = maybe Nothing streamOptions mbHuggingfaceParams+        -- , Huggingface.responseFormat = maybe Nothing responseFormat mbHuggingfaceParams+        -- , Huggingface.tools = maybe Nothing tools mbHuggingfaceParams+        -- , Huggingface.toolChoice = maybe Nothing toolChoice mbHuggingfaceParams+        }+      Huggingface.HuggingfaceStreamHandler+        { Huggingface.onComplete = onComplete+        , Huggingface.onToken = onToken . chunkToText+        }+    where+      chunkToText :: Huggingface.ChatCompletionChunk -> Text+      chunkToText Huggingface.ChatCompletionChunk {..} = do+        case listToMaybe chunkChoices of+          Nothing -> ""+          Just Huggingface.ChoiceChunk {..} ->+            fromMaybe "" ((\Huggingface.Delta {..} -> deltaContent) delta)++toHuggingfaceMessages :: LLM.ChatMessage -> [Huggingface.Message]+toHuggingfaceMessages msgs = map go (NE.toList msgs)+  where+    toRole :: LLM.Role -> Huggingface.Role+    toRole r = case r of+      LLM.System -> Huggingface.System+      LLM.User -> Huggingface.User+      LLM.Assistant -> Huggingface.Assistant+      LLM.Tool -> Huggingface.Tool+      _ -> Huggingface.System+    -- LLM.Developer -> Huggingface.Developer+    -- LLM.Function -> Huggingface.Function++    go :: LLM.Message -> Huggingface.Message+    go msg =+      Huggingface.defaultMessage+        { Huggingface.role = toRole $ LLM.role msg+        , Huggingface.content = Huggingface.TextContent (LLM.content msg)+        }

@@ -0,0 +1,686 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++{- |+Module:      Langchain.LLM.Internal.Huggingface+Copyright:   (c) 2025 Tushar Adhatrao+License:     MIT+Maintainer:  Tushar Adhatrao <tusharadhatrao@gmail.com>+Stability:   experimental++Internal types for interfacing with Huggingface.+https://huggingface.co/docs/inference-providers/providers/cerebras+-}+module Langchain.LLM.Internal.Huggingface+  ( -- * Types+    StreamOptions (..)+  , HuggingfaceChatCompletionRequest (..)+  , Message (..)+  , MessageContent (..)+  , ImageUrl (..)+  , Role (..)+  , ContentObject (..)+  , Tool_ (..)+  , Function_ (..)+  , ToolChoice (..)+  , SpecificToolChoice (..)+  , ResponseFormat (..)+  , ChatCompletionResponse (..)+  , ChatCompletionChunk (..)+  , Choice (..)+  , ChoiceChunk (..)+  , Usage (..)+  , TimeInfo (..)+  , ChunkUsage (..)+  , ChunkTimeInfo (..)+  , Delta (..)+  , Provider (..)+  , HuggingfaceStreamHandler (..)++    -- * Functions+  , providerLinks+  , getProviderLink+  , createChatCompletion+  , defaultHuggingfaceChatCompletionRequest+  , defaultMessage+  , createChatCompletionStream+  , defaultHuggingfaceStreamHandler+  ) where++import Conduit+import Data.Aeson+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.IORef+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import GHC.Generics+import Network.HTTP.Conduit+import Network.HTTP.Simple+  ( getResponseBody+  , getResponseStatus+  , setRequestBodyJSON+  , setRequestHeader+  , setRequestMethod+  , setRequestSecure+  )+import Network.HTTP.Types.Status (statusCode)++-- | Specifies the format of the response.+data ResponseFormat = RegexFormat String | JsonSchemaFormat Value+  deriving (Show, Eq, Generic)++instance ToJSON ResponseFormat where+  toJSON (RegexFormat regEx) = object ["type" .= ("regex" :: Text), "value" .= regEx]+  toJSON (JsonSchemaFormat schema) =+    object+      [ "type" .= ("json" :: Text)+      , "value" .= schema+      ]++instance FromJSON ResponseFormat where+  parseJSON = withObject "ResponseFormat" $ \v -> do+    formatType <- v .: "type"+    case formatType of+      String "regex" -> RegexFormat <$> v .: "value"+      String "json" -> JsonSchemaFormat <$> v .: "value"+      _ -> fail $ "Invalid response format type: " ++ show formatType++-- | Represents a tool that can be used in the conversation.+data Tool_ = Tool_+  { toolType :: Text+  -- ^ The type of the tool+  , function :: Function_+  -- ^ The function associated with the tool+  }+  deriving (Show, Eq, Generic)++instance ToJSON Tool_ where+  toJSON Tool_ {..} =+    object+      [ "type" .= toolType+      , "function" .= function+      ]++instance FromJSON Tool_ where+  parseJSON = withObject "Tool" $ \v ->+    Tool_+      <$> v .: "type"+      <*> v .: "function"++-- | Represents a function that can be called by the model.+data Function_ = Function_+  { functionName :: Text+  -- ^ The name of the function+  , description :: Maybe Text+  -- ^ Optional description of the function+  , arguments :: Maybe Value+  -- ^ Optional parameters for the function+  }+  deriving (Show, Eq, Generic)++instance ToJSON Function_ where+  toJSON Function_ {..} =+    object $+      [ "name" .= functionName+      ]+        ++ maybe [] (\d -> ["description" .= d]) description+        ++ maybe [] (\p -> ["arguments" .= p]) arguments++instance FromJSON Function_ where+  parseJSON = withObject "Function" $ \v ->+    Function_+      <$> v .: "name"+      <*> v .:? "description"+      <*> v .:? "arguments"++-- | Specifies how the model should choose tools.+data ToolChoice = None | Auto | Required | SpecificTool SpecificToolChoice+  deriving (Show, Eq, Generic)++instance ToJSON ToolChoice where+  toJSON None = String "none"+  toJSON Auto = String "auto"+  toJSON Required = String "required"+  toJSON (SpecificTool choice) = toJSON choice++instance FromJSON ToolChoice where+  parseJSON (String "none") = return None+  parseJSON (String "auto") = return Auto+  parseJSON (String "required") = return Required+  parseJSON o@(Object _) = SpecificTool <$> parseJSON o+  parseJSON invalid = fail $ "Invalid tool choice: " ++ show invalid++-- | Provides details for a specific tool choice.+data SpecificToolChoice = SpecificToolChoice+  { specificToolChoiceFunction :: Value+  -- ^ Function details+  }+  deriving (Show, Eq, Generic)++instance ToJSON SpecificToolChoice where+  toJSON SpecificToolChoice {..} =+    object+      [ "function" .= specificToolChoiceFunction+      ]++instance FromJSON SpecificToolChoice where+  parseJSON = withObject "SpecificToolChoice" $ \v ->+    SpecificToolChoice+      <$> v .: "function"++-- | Options for streaming responses.+data StreamOptions = StreamOptions+  { includeUsage :: Bool+  -- ^ Whether to include usage information+  }+  deriving (Show, Eq)++instance ToJSON StreamOptions where+  toJSON StreamOptions {..} =+    object+      [ "include_usage" .= includeUsage+      ]++instance FromJSON StreamOptions where+  parseJSON = withObject "StreamOptions" $ \v ->+    StreamOptions <$> v .: "include_usage"++-- | Huggingface supporting Roles+data Role = User | Assistant | Tool | System+  deriving (Eq, Show, Generic)++instance ToJSON Role where+  toJSON User = String "user"+  toJSON Assistant = String "assistant"+  toJSON Tool = String "tool"+  toJSON System = String "system"++instance FromJSON Role where+  parseJSON = withText "Role" $ \t -> case t of+    "user" -> pure User+    "assistant" -> pure Assistant+    "tool" -> pure Tool+    "system" -> pure System+    _ -> fail $ "Unknown role: " ++ T.unpack t++-- | Image url object+data ImageUrl = ImageUrl+  { url :: String+  }+  deriving (Eq, Show, Generic)++instance ToJSON ImageUrl where+  toJSON (ImageUrl url) = object ["url" .= url]++instance FromJSON ImageUrl where+  parseJSON = withObject "ImageUrl" $ \v ->+    ImageUrl <$> v .: "url"++-- | ContentObject+data ContentObject = ContentObject+  { contentType :: Text+  , contentText :: Maybe Text+  , imageUrl :: Maybe ImageUrl+  }+  deriving (Eq, Show, Generic)++instance ToJSON ContentObject where+  toJSON (ContentObject contentType contentText imageUrl) =+    object $+      ["type" .= contentType]+        ++ maybe [] (\t -> ["text" .= t]) contentText+        ++ maybe [] (\i -> ["image_url" .= i]) imageUrl++instance FromJSON ContentObject where+  parseJSON = withObject "ContentObject" $ \v ->+    ContentObject+      <$> v .: "type"+      <*> v .:? "text"+      <*> v .:? "image_url"++-- | Message could be either simple text or an object+data MessageContent = MessageContent [ContentObject] | TextContent Text+  deriving (Eq, Show)++instance ToJSON MessageContent where+  toJSON (MessageContent contentObjects) = toJSON contentObjects+  toJSON (TextContent text) = String text++instance FromJSON MessageContent where+  parseJSON v@(String _) = TextContent <$> parseJSON v+  parseJSON v = MessageContent <$> parseJSON v++-- | Huggingface's Message type+data Message = Message+  { role :: Role+  , content :: MessageContent+  , name :: Maybe String+  }+  deriving (Eq, Show, Generic)++-- | Default message type+defaultMessage :: Message+defaultMessage =+  Message+    { role = User+    , content = TextContent "What is the meaining of life?"+    , name = Nothing+    }++instance ToJSON Message where+  toJSON (Message role content name) =+    object $+      ["role" .= role, "content" .= content]+        ++ maybe [] (\n -> ["name" .= n]) name++instance FromJSON Message where+  parseJSON = withObject "Message" $ \v ->+    Message+      <$> v .: "role"+      <*> v .: "content"+      <*> v .:? "name"++{- | $providers+Supported providers and their API endpoints:++- Cerebras: @https://router.huggingface.co/cerebras/...+- Cohere: @https://router.huggingface.co/cohere/...+- Fireworks: @https://router.huggingface.co/fireworks-ai/...+- HFInference: @https://router.huggingface.co/hf-inference/...+-}+getProviderLink :: Provider -> Maybe String+getProviderLink provider = Map.lookup provider providerLinks++-- | Map of Providers to their respective links+providerLinks :: Map.Map Provider String+providerLinks =+  Map.fromList+    [ (Cerebras, "https://router.huggingface.co/cerebras/v1/chat/completions")+    , (Cohere, "https://router.huggingface.co/cohere/compatibility/v1/chat/completions")+    , (FalAI, "https://router.huggingface.co/fal-ai/fal-ai/whisper")+    , (Fireworks, "https://router.huggingface.co/fireworks-ai/inference/v1/chat/completions")+    , (Hyperbolic, "https://router.huggingface.co/hyperbolic/v1/chat/completions")+    , (HFInference, "https://router.huggingface.co/hf-inference/models/Qwen/QwQ-32B/v1/chat/completions")+    , (Nebius, "https://router.huggingface.co/nebius/v1/chat/completions")+    , (Novita, "https://router.huggingface.co/novita/v3/openai/chat/completions")+    , (SambaNova, "https://router.huggingface.co/sambanova/v1/chat/completions")+    , (Together, "https://router.huggingface.co/together/v1/chat/completions")+    ]++{- |+    Providers integrated with Huggingface Inference+    https://huggingface.co/docs/inference-providers/index#partners+-}+data Provider+  = Cerebras+  | Cohere+  | FalAI+  | Fireworks+  | HFInference+  | Hyperbolic+  | Nebius+  | Novita+  | Replicate+  | SambaNova+  | Together+  deriving (Show, Eq, Ord)++-- | Chat completion request body type. Separatly passes provider.+data HuggingfaceChatCompletionRequest = HuggingfaceChatCompletionRequest+  { provider :: Provider+  , timeout :: Maybe Int+  , messages :: [Message]+  , model :: Text+  , stream :: Bool+  , maxTokens :: Maybe Integer+  , frequencyPenalty :: Maybe Double+  , logProbs :: Maybe Bool+  , presencePenalty :: Maybe Double+  , seed :: Maybe Int+  , stop :: Maybe [String]+  , temperature :: Maybe Double+  , toolPrompt :: Maybe String+  , topLogprobs :: Maybe Int+  , topP :: Maybe Double+  , streamOptions :: Maybe StreamOptions+  , responseFormat :: Maybe ResponseFormat+  , tools :: Maybe [Tool_]+  , toolChoice :: Maybe ToolChoice+  }+  deriving (Eq, Show, Generic)++-- | Default values of chat completion request.+defaultHuggingfaceChatCompletionRequest :: HuggingfaceChatCompletionRequest+defaultHuggingfaceChatCompletionRequest =+  HuggingfaceChatCompletionRequest+    { provider = Cerebras+    , timeout = Nothing+    , messages = [defaultMessage]+    , model = "llama-3.3-70b"+    , stream = False+    , maxTokens = Nothing+    , frequencyPenalty = Nothing+    , logProbs = Nothing+    , presencePenalty = Nothing+    , seed = Nothing+    , stop = Nothing+    , temperature = Nothing+    , toolPrompt = Nothing+    , topLogprobs = Nothing+    , topP = Nothing+    , streamOptions = Nothing+    , responseFormat = Nothing+    , tools = Nothing+    , toolChoice = Nothing+    }++instance ToJSON HuggingfaceChatCompletionRequest where+  toJSON+    ( HuggingfaceChatCompletionRequest+        _+        _+        messages+        model+        stream+        maxTokens+        frequencyPenalty+        logProbs+        presencePenalty+        seed+        stop+        temperature+        toolPrompt+        topLogprobs+        topP+        streamOptions+        responseFormat+        tools+        toolChoice+      ) =+      object $+        [ "messages" .= messages+        , "model" .= model+        , "stream" .= stream+        ]+          ++ optionalField "max_tokens" maxTokens+          ++ optionalField "frequency_penalty" frequencyPenalty+          ++ optionalField "logprobs" logProbs+          ++ optionalField "presence_penalty" presencePenalty+          ++ optionalField "seed" seed+          ++ optionalField "stop" stop+          ++ optionalField "temperature" temperature+          ++ optionalField "tool_prompt" toolPrompt+          ++ optionalField "top_logprobs" topLogprobs+          ++ optionalField "top_p" topP+          ++ optionalField "stream_options" streamOptions+          ++ optionalField "response_format" responseFormat+          ++ optionalField "tools" tools+          ++ optionalField "tool_choice" toolChoice+      where+        optionalField _ Nothing = []+        optionalField key (Just value) = [(key, toJSON value)]++-- | Choice options+data Choice = Choice+  { finish_reason :: Text+  , index :: Int+  , message :: Message+  }+  deriving (Eq, Show, Generic)++instance FromJSON Choice where+  parseJSON = withObject "Choice" $ \v ->+    Choice+      <$> v .: "finish_reason"+      <*> v .: "index"+      <*> v .: "message"++-- | Token usage+data Usage = Usage+  { prompt_tokens :: Int+  , completion_tokens :: Int+  , total_tokens :: Int+  }+  deriving (Eq, Show, Generic)++instance FromJSON Usage where+  parseJSON = withObject "Usage" $ \v ->+    Usage+      <$> v .: "prompt_tokens"+      <*> v .: "completion_tokens"+      <*> v .: "total_tokens"++-- | Timeinfo+data TimeInfo = TimeInfo+  { queue_time :: Double+  , prompt_time :: Double+  , completion_time :: Double+  , total_time :: Double+  , timeInfoCreated :: Int+  }+  deriving (Eq, Show, Generic)++instance FromJSON TimeInfo where+  parseJSON = withObject "TimeInfo" $ \v ->+    TimeInfo+      <$> v .: "queue_time"+      <*> v .: "prompt_time"+      <*> v .: "completion_time"+      <*> v .: "total_time"+      <*> v .: "created"++-- | Response type for chat completion+data ChatCompletionResponse = ChatCompletionResponse+  { responseId :: Text+  , choices :: [Choice]+  , created :: Int+  , chatCompletionModel :: Text+  , system_fingerprint :: Text+  , chatCompletionObject :: Text+  , usage :: Usage+  , time_info :: TimeInfo+  }+  deriving (Eq, Show, Generic)++instance FromJSON ChatCompletionResponse where+  parseJSON = withObject "ChatCompletion" $ \v ->+    ChatCompletionResponse+      <$> v .: "id"+      <*> v .: "choices"+      <*> v .: "created"+      <*> v .: "model"+      <*> v .: "system_fingerprint"+      <*> v .: "object"+      <*> v .: "usage"+      <*> v .: "time_info"++-- | Response for stream+data Delta = Delta+  { deltaContent :: Maybe Text+  }+  deriving (Eq, Show, Generic)++instance FromJSON Delta where+  parseJSON = withObject "Delta" $ \v ->+    Delta+      <$> v .:? "content"++-- | Represents type for choice object from stream response+data ChoiceChunk = ChoiceChunk+  { delta :: Delta+  , choiceFinishReason :: Maybe Text+  , choiceIndex :: Int+  }+  deriving (Eq, Show, Generic)++instance FromJSON ChoiceChunk where+  parseJSON = withObject "ChoiceChunk" $ \v ->+    ChoiceChunk+      <$> v .: "delta"+      <*> v .:? "finish_reason"+      <*> v .: "index"++-- | Represent type for usage object from stream response+data ChunkUsage = ChunkUsage+  { promptTokens :: Int+  , usageCompletionTokens :: Int+  , usageTotalTokens :: Int+  }+  deriving (Eq, Show, Generic)++instance FromJSON ChunkUsage where+  parseJSON = withObject "Usage" $ \v ->+    ChunkUsage+      <$> v .: "prompt_tokens"+      <*> v .: "completion_tokens"+      <*> v .: "total_tokens"++-- | Represents type for timeinfo object from stream reponse+data ChunkTimeInfo = ChunkTimeInfo+  { timeInfoQueueTime :: Double+  , timeInfoPromptTime :: Double+  , timeInfoCompletionTime :: Double+  , timeInfoTotalTime :: Double+  , chunkTimeInfoCreated :: Int+  }+  deriving (Eq, Show, Generic)++instance FromJSON ChunkTimeInfo where+  parseJSON = withObject "TimeInfo" $ \v ->+    ChunkTimeInfo+      <$> v .: "queue_time"+      <*> v .: "prompt_time"+      <*> v .: "completion_time"+      <*> v .: "total_time"+      <*> v .: "created"++-- | Type that represents stream response+data ChatCompletionChunk = ChatCompletionChunk+  { chatCompletionChunkId :: Text+  , chunkChoices :: [ChoiceChunk]+  , chunkCreated :: Int+  , chunkModel :: Text+  , chunkSystemFingerprint :: Text+  , chunkObject :: Text+  , chunkUsage :: Maybe Usage+  , chunkTimeInfo :: Maybe ChunkTimeInfo+  }+  deriving (Eq, Show, Generic)++instance FromJSON ChatCompletionChunk where+  parseJSON = withObject "ChatCompletionChunk" $ \v ->+    ChatCompletionChunk+      <$> v .: "id"+      <*> v .: "choices"+      <*> v .: "created"+      <*> v .: "model"+      <*> v .: "system_fingerprint"+      <*> v .: "object"+      <*> v .:? "usage"+      <*> v .:? "time_info"++-- | Chat completion function+createChatCompletion ::+  Text -> HuggingfaceChatCompletionRequest -> IO (Either String ChatCompletionResponse)+createChatCompletion apiKey r = do+  case getProviderLink (provider r) of+    Nothing -> pure $ Left "Incompatible provider"+    Just link -> do+      request_ <- parseRequest link+      manager <-+        newManager+          tlsManagerSettings+            { managerResponseTimeout =+                responseTimeoutMicro (fromMaybe 60 (timeout r) * 1000000)+            }+      let req =+            setRequestMethod "POST" $+              setRequestSecure True $+                setRequestHeader "Content-Type" ["application/json"] $+                  setRequestHeader "Authorization" ["Bearer " <> encodeUtf8 apiKey] $+                    setRequestBodyJSON r $+                      request_++      response <- httpLbs req manager+      let status = statusCode $ getResponseStatus response+      if status >= 200 && status < 300+        then case eitherDecode (getResponseBody response) of+          Left err -> return $ Left $ "JSON parse error: " <> err+          Right completionResponse -> return $ Right completionResponse+        else return $ Left $ "API error: " <> show status <> " " <> show (getResponseBody response)++{- | Handler for streaming chat completion responses.+Provides callbacks for processing each token and handling stream completion.+-}+data HuggingfaceStreamHandler = HuggingfaceStreamHandler+  { onToken :: ChatCompletionChunk -> IO ()+  -- ^ Callback for each token (chunk) received+  , onComplete :: IO ()+  -- ^ Callback when the stream is complete+  }++-- | Default values for stream handling in Huggingface LLM+defaultHuggingfaceStreamHandler :: HuggingfaceStreamHandler+defaultHuggingfaceStreamHandler =+  HuggingfaceStreamHandler+    { onToken = print+    , onComplete = pure ()+    }++-- | Streaming function for huggingface+createChatCompletionStream ::+  Text -> HuggingfaceChatCompletionRequest -> HuggingfaceStreamHandler -> IO (Either String ())+createChatCompletionStream apiKey r HuggingfaceStreamHandler {..} = do+  case getProviderLink (provider r) of+    Nothing -> pure $ Left "Incompatible provider"+    Just link -> do+      request_ <- parseRequest link+      let httpReq =+            setRequestHeader "Authorization" ["Bearer " <> encodeUtf8 apiKey] $+              setRequestMethod "POST" $+                setRequestSecure True $+                  setRequestHeader "Content-Type" ["application/json"] $+                    setRequestBodyJSON r $+                      request_++      manager <-+        newManager+          tlsManagerSettings+            { managerResponseTimeout =+                responseTimeoutMicro (fromMaybe 60 (timeout r) * 1000000)+            }+      runResourceT $ do+        response <- http httpReq manager+        bufferRef <- liftIO $ newIORef BS.empty+        runConduit $+          responseBody response+            .| linesUnboundedAsciiC+            .| mapM_C (liftIO . processLine bufferRef)++      onComplete+      return $ Right ()+      where+        processLine bufferRef line = do+          if BS.isPrefixOf "data: " line+            then do+              do+                let content = BS.drop 6 line -- Remove "data: " prefix+                case decode (LBS.fromStrict content) of+                  Just chunk -> onToken chunk+                  Nothing -> do+                    -- Handle potential partial JSON by buffering+                    oldBuffer <- readIORef bufferRef+                    let newBuffer = oldBuffer <> content+                    writeIORef bufferRef newBuffer+                    -- Try to parse the combined buffer+                    case decode (LBS.fromStrict newBuffer) of+                      Just chunk -> do+                        onToken chunk+                        writeIORef bufferRef BS.empty -- Clear buffer after successful parse+                      Nothing -> return () -- Keep in buffer for next chunk+            else return () -- Ignore non-data lines

@@ -0,0 +1,1149 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++{- |+Module      : Langchain.LLM.Internal.OpenAI+Description : Internal module for OpenAI chat completion API interactions+Copyright   : (c) 2025 Tushar Adhatrao+License     : MIT+Maintainer  : Tushar Adhatrao <tusharadhatrao@gmail.com>+Stability   : experimental++This module provides data types and functions to interact with OpenAI's chat completion API. It includes types for requests, responses, and streaming handlers, as well as functions to create and handle chat completion requests and streams. Designed for internal use within the LangChain library, it can also be used directly for fine-grained control over API interactions.++Key Features++- Data types for chat completion requests and responses+- Support for streaming chat completions with real-time token processing+- Default values and configurations for common use cases+- Comprehensive error handling for API interactions++### Example Usage++@+import Data.Text (Text)+import Langchain.LLM.Internal.OpenAI++-- Create a simple message+let message = defaultMessage { role = User, content = Just (StringContent "Hello, how are you?") }++-- Create a chat completion request+let request = defaultChatCompletionRequest+      { messages = [message]+      , model = "gpt-3.5-turbo"+      , temperature = Just 0.7+      }++-- Send the request+response <- createChatCompletion "your-api-key" request+case response of+  Right res -> print (choices res)+  Left err -> putStrLn $ "Error: " ++ err+@++- Streaming Chat Completions:++@+import Langchain.LLM.Internal.OpenAI++-- Define a stream handler+let handler = OpenAIStreamHandler+      { onToken = \chunk -> putStr (maybe "" id $ contentForDelta $ delta $ head $ chunkChoices chunk)+      , onComplete = putStrLn "Stream complete"+      }++-- Create a streaming request+let streamRequest = request { stream = Just True }++-- Start streaming+result <- createChatCompletionStream "your-api-key" streamRequest handler+case result of+  Right () -> putStrLn "Streaming completed successfully"+  Left err -> putStrLn $ "Error: " ++ err+@+-}+module Langchain.LLM.Internal.OpenAI+  ( -- * Types+    ChatCompletionChunk (..)+  , ChunkChoice (..)+  , Delta (..)+  , OpenAIStreamHandler (..)+  , 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 (..)++    -- * Default values for types+  , defaultChatCompletionRequest+  , createChatCompletion+  , createChatCompletionStream+  , defaultMessage+  , defaultPredictionOutput+  , defaultResponseFormat+  , defaultStreamOptions+  , defaultWebSearchOptions+  , defaultUserLocation+  , defaultAudioConfig+  , defaultToolChoice+  , defaultSpecificToolChoice+  , defaultReasoningEffort+  , defaultFunction+  ) where++import Conduit+import Data.Aeson+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.IORef+import Data.Map (Map)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)+import GHC.Generics+import Network.HTTP.Conduit+import Network.HTTP.Simple+  ( getResponseStatus+  , setRequestBodyJSON+  , setRequestHeader+  , setRequestMethod+  , setRequestSecure+  , getResponseBody+  )+import Network.HTTP.Types.Status (statusCode)++{- | Represents a chunk of the chat completion response in a streaming context.+Contains a list of possible choices for the completion.+-}+data ChatCompletionChunk = ChatCompletionChunk+  { chunkChoices :: [ChunkChoice]+  -- ^ List of choices in this chunk of the response+  }+  deriving (Show)++instance FromJSON ChatCompletionChunk where+  parseJSON = withObject "ChatCompletionChunk" $ \v ->+    ChatCompletionChunk <$> v .: "choices"++{- | Represents a single choice in a chat completion chunk.+Includes the incremental content and an optional reason for finishing.+-}+data ChunkChoice = ChunkChoice+  { delta :: Delta+  -- ^ Incremental content added in this chunk+  , finishReason :: Maybe FinishReason+  -- ^ Reason why the completion stopped, if applicable+  }+  deriving (Show)++instance FromJSON ChunkChoice where+  parseJSON = withObject "ChunkChoice" $ \v ->+    ChunkChoice <$> v .: "delta" <*> v .:? "finish_reason"++-- | Represents the incremental content added in a chat completion chunk.+data Delta = Delta+  { contentForDelta :: Maybe Text+  -- ^ Optional text content added in this chunk+  }+  deriving (Show)++instance FromJSON Delta where+  parseJSON = withObject "Delta" $ \v ->+    Delta <$> v .:? "content"++{- | Handler for streaming chat completion responses.+Provides callbacks for processing each token and handling stream completion.+-}+data OpenAIStreamHandler = OpenAIStreamHandler+  { onToken :: ChatCompletionChunk -> IO ()+  -- ^ Callback for each token (chunk) received+  , onComplete :: IO ()+  -- ^ Callback when the stream is complete+  }++{- | Represents the main request for chat completions.+Contains all parameters for configuring the OpenAI chat completion API call.+-}+data ChatCompletionRequest = ChatCompletionRequest+  { messages :: [Message]+  -- ^ List of messages in the conversation history+  , model :: Text+  -- ^ The model to use for completion (e.g., "gpt-3.5-turbo")+  , timeout :: Maybe Int+  -- ^ Override default response timeout in seconds. Default = 60 seconds+  , frequencyPenalty :: Maybe Double+  -- ^ Penalty for frequent tokens (range: -2.0 to 2.0)+  , logitBias :: Maybe (Map Text Double)+  -- ^ Bias for specific tokens+  , logprobs :: Maybe Bool+  -- ^ Whether to return log probabilities+  , maxCompletionTokens :: Maybe Int+  -- ^ Maximum tokens to generate in the completion+  , maxTokens :: Maybe Int+  -- ^ Maximum tokens in the response+  , metadata :: Maybe (Map Text Text)+  -- ^ Metadata to attach to the request+  , modalities :: Maybe [Modality]+  -- ^ Modalities to use (e.g., text, audio)+  , n :: Maybe Int+  -- ^ Number of completions to generate+  , parallelToolCalls :: Maybe Bool+  -- ^ Whether to allow parallel tool calls+  , prediction :: Maybe PredictionOutput+  -- ^ Prediction output configuration+  , presencePenalty :: Maybe Double+  -- ^ Penalty for new tokens (range: -2.0 to 2.0)+  , reasoningEffort :: Maybe ReasoningEffort+  -- ^ Level of reasoning effort+  , responseFormat :: Maybe ResponseFormat+  -- ^ Format of the response (e.g., JSON)+  , seed :: Maybe Int+  -- ^ Seed for deterministic outputs+  , serviceTier :: Maybe Text+  -- ^ Service tier to use+  , stop :: Maybe (Either Text [Text])+  -- ^ Stop sequences to end the completion+  , store :: Maybe Bool+  -- ^ Whether to store the conversation+  , stream :: Maybe Bool+  -- ^ Whether to stream the response+  , streamOptions :: Maybe StreamOptions+  -- ^ Options for streaming+  , temperature :: Maybe Double+  -- ^ Sampling temperature (range: 0.0 to 2.0)+  , toolChoice :: Maybe ToolChoice+  -- ^ How to choose tools for the model+  , tools :: Maybe [Tool_]+  -- ^ Tools available to the model+  , topLogprobs :: Maybe Int+  -- ^ Number of top log probabilities to return+  , topP :: Maybe Double+  -- ^ Nucleus sampling parameter (range: 0.0 to 1.0)+  , user :: Maybe Text+  -- ^ User identifier+  , webSearchOptions :: Maybe WebSearchOptions+  -- ^ Options for web search features+  , audio :: Maybe AudioConfig+  -- ^ Configuration for audio processing+  }+  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++{- | Represents the response from a chat completion request.+Contains the generated choices, metadata, and usage information.+-}+data ChatCompletionResponse = ChatCompletionResponse+  { choices :: [Choice]+  -- ^ List of completion choices+  , created :: Integer+  -- ^ Timestamp of when the response was created+  , id_ :: Text+  -- ^ Unique identifier for the response+  , responseModel :: Text+  -- ^ The model used for the completion+  , object_ :: Text+  -- ^ Type of the response object+  , responseServiceTier :: Maybe Text+  -- ^ Service tier used+  , systemFingerprint :: Text+  -- ^ System fingerprint+  , usage :: Usage+  -- ^ Token usage information+  }+  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"++{- | Represents a single message in a conversation.+Contains the role, content, and optional metadata like function calls or audio responses.+-}+data Message = Message+  { role :: Role+  -- ^ The role of the message sender+  , content :: Maybe MessageContent+  -- ^ The content of the message+  , name :: Maybe Text+  -- ^ Optional name of the sender+  , functionCall :: Maybe FunctionCall_+  -- ^ Optional function call information+  , toolCalls :: Maybe [ToolCall]+  -- ^ Optional tool call information+  , messageToolCallId :: Maybe Text+  -- ^ Optional tool call ID+  , messageAudio :: Maybe AudioResponse+  -- ^ Optional audio response+  , refusal :: Maybe Text+  -- ^ Optional refusal reason+  }+  deriving (Show, Eq, Generic)++-- | Default message with User role and no content.+defaultMessage :: Message+defaultMessage =+  Message+    { role = User+    , content = Nothing+    , name = Nothing+    , functionCall = Nothing+    , toolCalls = Nothing+    , messageToolCallId = Nothing+    , messageAudio = 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]) messageToolCallId+        ++ maybe [] (\a -> ["audio" .= a]) messageAudio+        ++ 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"++{- | Represents different roles in a conversation.+Each role has a specific meaning in the context of the chat.+-}+data Role+  = -- | Human user input+    User+  | -- | AI-generated response+    Assistant+  | -- | System-level instructions+    System+  | -- | Special role for developer messages+    Developer+  | -- | Tool interaction messages+    Tool+  | -- | Function call messages+    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++-- | Represents the content of a message, which can be a simple string or structured parts.+data MessageContent+  = -- | Simple text content+    StringContent Text+  | -- | Structured content parts+    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++-- | Represents a piece of text content with a type.+data TextContent = TextContent+  { text_ :: Text+  -- ^ The text content+  , contentType :: Text+  -- ^ The type of the content+  }+  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"++-- | Represents a tool that can be used in the conversation.+data Tool_ = Tool_+  { toolType :: Text+  -- ^ The type of the tool+  , function :: Function_+  -- ^ The function associated with the tool+  }+  deriving (Show, Eq, Generic)++instance ToJSON Tool_ where+  toJSON Tool_ {..} =+    object+      [ "type" .= toolType+      , "function" .= function+      ]++instance FromJSON Tool_ where+  parseJSON = withObject "Tool" $ \v ->+    Tool_+      <$> v .: "type"+      <*> v .: "function"++-- | Represents a function that can be called by the model.+data Function_ = Function_+  { functionName :: Text+  -- ^ The name of the function+  , description :: Maybe Text+  -- ^ Optional description of the function+  , parameters :: Maybe Value+  -- ^ Optional parameters for the function+  , strict :: Maybe Bool+  -- ^ Optional strictness flag+  }+  deriving (Show, Eq, Generic)++instance ToJSON Function_ where+  toJSON Function_ {..} =+    object $+      [ "name" .= functionName+      ]+        ++ 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"++-- | Represents a call to a tool.+data ToolCall = ToolCall+  { toolCallId :: Text+  -- ^ The ID of the tool call+  , toolCallToolType :: Text+  -- ^ The type of the tool+  , toolCallfunction :: FunctionCall_+  -- ^ The function call+  }+  deriving (Show, Eq, Generic)++instance ToJSON ToolCall where+  toJSON ToolCall {..} =+    object+      [ "id" .= toolCallId+      , "type" .= toolCallToolType+      , "function" .= toolCallfunction+      ]++instance FromJSON ToolCall where+  parseJSON = withObject "ToolCall" $ \v ->+    ToolCall+      <$> v .: "id"+      <*> v .: "type"+      <*> v .: "function"++-- | Represents a call to a function.+data FunctionCall_ = FunctionCall_+  { functionCallName :: Text+  -- ^ The name of the function+  , arguments :: Text+  -- ^ The arguments for the function+  }+  deriving (Show, Eq, Generic)++instance ToJSON FunctionCall_ where+  toJSON FunctionCall_ {..} =+    object+      [ "name" .= functionCallName+      , "arguments" .= arguments+      ]++instance FromJSON FunctionCall_ where+  parseJSON = withObject "FunctionCall" $ \v ->+    FunctionCall_+      <$> v .: "name"+      <*> v .: "arguments"++-- | Represents token usage information.+data Usage = Usage+  { completionTokens :: Int+  -- ^ Tokens used in completion+  , promptTokens :: Int+  -- ^ Tokens in the prompt+  , totalTokens :: Int+  -- ^ Total tokens used+  , completionTokensDetails :: Maybe CompletionTokensDetails+  -- ^ Detailed completion token info+  , promptTokensDetails :: Maybe PromptTokensDetails+  -- ^ Detailed prompt token info+  }+  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"++-- | Represents a single choice in the chat completion response.+data Choice = Choice+  { choiceFinishReason :: Maybe FinishReason+  -- ^ Reason why the completion stopped+  , index :: Int+  -- ^ Index of the choice+  , choiceLogprobs :: Maybe LogProbs+  -- ^ Log probabilities, if requested+  , message :: Message+  -- ^ The generated message+  }+  deriving (Show, Eq, Generic)++instance FromJSON Choice where+  parseJSON = withObject "Choice" $ \v ->+    Choice+      <$> v .: "finish_reason"+      <*> v .: "index"+      <*> v .:? "logprobs"+      <*> v .: "message"++-- | Represents the reason why the completion stopped.+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++-- | Represents log probability information for the completion.+data LogProbs = LogProbs+  { contentForLogProbs :: Maybe [LogProbContent]+  -- ^ Log probs for content+  , logProbsRefusal :: Maybe [LogProbContent]+  -- ^ Log probs for refusal+  }+  deriving (Show, Eq, Generic)++instance FromJSON LogProbs where+  parseJSON = withObject "LogProbs" $ \v ->+    LogProbs+      <$> v .:? "content"+      <*> v .:? "refusal"++-- | Represents log probability content for a token.+data LogProbContent = LogProbContent+  { bytes :: Maybe [Int]+  -- ^ Optional byte representation+  , logprob :: Double+  -- ^ Log probability of the token+  , token :: Text+  -- ^ The token+  , logProbContentTopLogprobs :: [TopLogProb]+  -- ^ Top log probabilities+  }+  deriving (Show, Eq, Generic)++instance FromJSON LogProbContent where+  parseJSON = withObject "LogProbContent" $ \v ->+    LogProbContent+      <$> v .:? "bytes"+      <*> v .: "logprob"+      <*> v .: "token"+      <*> v .: "top_logprobs"++-- | Represents a top log probability for a token.+data TopLogProb = TopLogProb+  { topLogProbBytes :: Maybe [Int]+  -- ^ Optional byte representation+  , topLogProbLogprob :: Double+  -- ^ Log probability+  , topLogProbToken :: Text+  -- ^ The token+  }+  deriving (Show, Eq, Generic)++instance FromJSON TopLogProb where+  parseJSON = withObject "TopLogProb" $ \v ->+    TopLogProb+      <$> v .:? "bytes"+      <*> v .: "logprob"+      <*> v .: "token"++{- | Configuration for audio processing.+Specifies format and voice preferences for text-to-speech.+-}+data AudioConfig = AudioConfig+  { format :: Text+  -- ^ Audio format (e.g., "mp3")+  , voice :: Text+  -- ^ Voice to use (e.g., "en-US")+  }+  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"++-- | Represents an audio response.+data AudioResponse = AudioResponse+  { audioResponseData :: Text+  -- ^ Audio data+  , expiresAt :: Integer+  -- ^ Expiration time+  , audioResponseId :: Text+  -- ^ Unique ID+  , transcript :: Text+  -- ^ Transcript of the audio+  }+  deriving (Show, Eq, Generic)++instance ToJSON AudioResponse where+  toJSON AudioResponse {..} =+    object+      [ "data" .= audioResponseData+      , "expires_at" .= expiresAt+      , "id" .= audioResponseId+      , "transcript" .= transcript+      ]++instance FromJSON AudioResponse where+  parseJSON = withObject "AudioResponse" $ \v ->+    AudioResponse+      <$> v .: "data"+      <*> v .: "expires_at"+      <*> v .: "id"+      <*> v .: "transcript"++-- | Represents different modalities for the conversation.+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++-- | Specifies how the model should choose tools.+data ToolChoice = None | Auto | Required | SpecificTool SpecificToolChoice+  deriving (Show, Eq, Generic)++instance ToJSON ToolChoice where+  toJSON None = String "none"+  toJSON Auto = String "auto"+  toJSON Required = String "required"+  toJSON (SpecificTool choice) = toJSON choice++instance FromJSON ToolChoice where+  parseJSON (String "none") = return None+  parseJSON (String "auto") = return Auto+  parseJSON (String "required") = return Required+  parseJSON o@(Object _) = SpecificTool <$> parseJSON o+  parseJSON invalid = fail $ "Invalid tool choice: " ++ show invalid++-- | Provides details for a specific tool choice.+data SpecificToolChoice = SpecificToolChoice+  { specificToolChoiceToolType :: Text+  -- ^ Type of the tool+  , specificToolChoiceFunction :: Value+  -- ^ Function details+  }+  deriving (Show, Eq, Generic)++instance ToJSON SpecificToolChoice where+  toJSON SpecificToolChoice {..} =+    object+      [ "type" .= specificToolChoiceToolType+      , "function" .= specificToolChoiceFunction+      ]++instance FromJSON SpecificToolChoice where+  parseJSON = withObject "SpecificToolChoice" $ \v ->+    SpecificToolChoice+      <$> v .: "type"+      <*> v .: "function"++-- | Indicates the level of reasoning effort.+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++-- | Represents prediction content.+data PredictionContent = PredictionContent+  { contentForPredictionContent :: MessageContent+  -- ^ The content+  , predictionContentType :: Text+  -- ^ Type of the content+  }+  deriving (Show, Eq, Generic)++instance ToJSON PredictionContent where+  toJSON PredictionContent {..} =+    object+      [ "content" .= contentForPredictionContent+      , "type" .= predictionContentType+      ]++instance FromJSON PredictionContent where+  parseJSON = withObject "PredictionContent" $ \v ->+    PredictionContent+      <$> v .: "content"+      <*> v .: "type"++-- | Represents prediction output.+data PredictionOutput = PredictionOutput+  { predictionType :: Text+  -- ^ Type of the prediction+  , contentForPredictionOutput :: MessageContent+  -- ^ The output content+  }+  deriving (Show, Eq, Generic)++instance ToJSON PredictionOutput where+  toJSON PredictionOutput {..} =+    object+      [ "type" .= predictionType+      , "content" .= contentForPredictionOutput+      ]++instance FromJSON PredictionOutput where+  parseJSON = withObject "PredictionOutput" $ \v ->+    PredictionOutput+      <$> v .: "type"+      <*> v .: "content"++-- | Specifies the format of the response.+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++-- | Options for streaming responses.+data StreamOptions = StreamOptions+  { includeUsage :: Bool+  -- ^ Whether to include usage information+  }+  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"++-- | Represents web search options.+data WebSearchOptions = WebSearchOptions+  { searchContextSize :: Maybe Text+  -- ^ Size of the search context+  , userLocation :: Maybe UserLocation+  -- ^ User location for context+  }+  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"++-- | Represents user location.+data UserLocation = UserLocation+  { approximate :: ApproximateLocation+  -- ^ Approximate location details+  }+  deriving (Show, Eq, Generic)++instance ToJSON UserLocation where+  toJSON UserLocation {..} =+    object+      [ "approximate" .= approximate+      ]++instance FromJSON UserLocation where+  parseJSON = withObject "UserLocation" $ \v ->+    UserLocation <$> v .: "approximate"++-- | Represents approximate location.+data ApproximateLocation = ApproximateLocation+  { locationType :: Text+  -- ^ Type of the location+  }+  deriving (Show, Eq, Generic)++instance ToJSON ApproximateLocation where+  toJSON ApproximateLocation {..} =+    object+      [ "type" .= locationType+      ]++instance FromJSON ApproximateLocation where+  parseJSON = withObject "ApproximateLocation" $ \v ->+    ApproximateLocation <$> v .: "type"++-- | Details about completion tokens.+data CompletionTokensDetails = CompletionTokensDetails+  { acceptedPredictionTokens :: Int+  -- ^ Accepted prediction tokens+  , audioTokens :: Int+  -- ^ Audio tokens+  , reasoningTokens :: Int+  -- ^ Reasoning tokens+  , rejectedPredictionTokens :: Int+  -- ^ Rejected prediction tokens+  }+  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"++-- | Details about prompt tokens.+data PromptTokensDetails = PromptTokensDetails+  { promptTokenDetailsAudioTokens :: Int+  -- ^ Audio tokens in the prompt+  , cachedTokens :: Int+  -- ^ Cached tokens+  }+  deriving (Show, Eq, Generic)++instance FromJSON PromptTokensDetails where+  parseJSON = withObject "PromptTokensDetails" $ \v ->+    PromptTokensDetails+      <$> v .: "audio_tokens"+      <*> v .: "cached_tokens"++-- | Default chat completion request with "gpt-4.1-nano" model.+defaultChatCompletionRequest :: ChatCompletionRequest+defaultChatCompletionRequest =+  ChatCompletionRequest+    { messages = []+    , model = "gpt-4.1-nano"+    , timeout = Just 60+    , 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 and returns the response.+Sends the request to OpenAI's API and parses the response.+-}+createChatCompletion :: Text -> ChatCompletionRequest -> IO (Either String ChatCompletionResponse)+createChatCompletion apiKey r = do+  request_ <- parseRequest "https://api.openai.com/v1/chat/completions"+  manager <-+    newManager+      tlsManagerSettings+        { managerResponseTimeout =+            responseTimeoutMicro (fromMaybe 60 (timeout r) * 1000000)+        }+  let req =+        setRequestMethod "POST" $+          setRequestSecure True $+            setRequestHeader "Content-Type" ["application/json"] $+              setRequestHeader "Authorization" ["Bearer " <> encodeUtf8 apiKey] $+                setRequestBodyJSON r $+                  request_++  response <- httpLbs req manager+  let status = statusCode $ getResponseStatus response+  if status >= 200 && status < 300+    then case eitherDecode (getResponseBody response) of+      Left err -> return $ Left $ "JSON parse error: " <> err+      Right completionResponse -> return $ Right completionResponse+    else return $ Left $ "API error: " <> show status <> " " <> show (getResponseBody response)++{- | Creates a streaming chat completion request.+Processes the stream using the provided handler.+-}+createChatCompletionStream ::+  Text -> ChatCompletionRequest -> OpenAIStreamHandler -> IO (Either String ())+createChatCompletionStream apiKey r OpenAIStreamHandler {..} = do+  request_ <- parseRequest "POST https://api.openai.com/v1/chat/completions"+  let httpReq =+        setRequestHeader "Authorization" ["Bearer " <> encodeUtf8 apiKey] $+          setRequestHeader "Content-Type" ["application/json"] $+            setRequestBodyJSON r $+              request_++  manager <-+    newManager+      tlsManagerSettings+        { managerResponseTimeout =+            responseTimeoutMicro (fromMaybe 60 (timeout r) * 1000000)+        }+  runResourceT $ do+    response <- http httpReq manager+    bufferRef <- liftIO $ newIORef BS.empty+    runConduit $+      responseBody response+        .| linesUnboundedAsciiC+        .| mapM_C (liftIO . processLine bufferRef)++  onComplete+  return $ Right ()+  where+    processLine bufferRef line = do+      if BS.isPrefixOf "data: " line+        then do+          if line == "data: [DONE]"+            then return () -- Stream is complete+            else do+              let content = BS.drop 6 line -- Remove "data: " prefix+              case decode (LBS.fromStrict content) of+                Just chunk -> onToken chunk+                Nothing -> do+                  -- Handle potential partial JSON by buffering+                  oldBuffer <- readIORef bufferRef+                  let newBuffer = oldBuffer <> content+                  writeIORef bufferRef newBuffer+                  -- Try to parse the combined buffer+                  case decode (LBS.fromStrict newBuffer) of+                    Just chunk -> do+                      onToken chunk+                      writeIORef bufferRef BS.empty -- Clear buffer after successful parse+                    Nothing -> return () -- Keep in buffer for next chunk+        else return () -- Ignore non-data lines++-- | Default prediction output.+defaultPredictionOutput :: PredictionOutput+defaultPredictionOutput =+  PredictionOutput+    { predictionType = "text"+    , contentForPredictionOutput = StringContent ""+    }++-- | Default response format (JSON object).+defaultResponseFormat :: ResponseFormat+defaultResponseFormat = JsonObjectFormat++-- | Default stream options.+defaultStreamOptions :: StreamOptions+defaultStreamOptions =+  StreamOptions+    { includeUsage = False+    }++-- | Default web search options.+defaultWebSearchOptions :: WebSearchOptions+defaultWebSearchOptions =+  WebSearchOptions+    { searchContextSize = Nothing+    , userLocation = Nothing+    }++-- | Default user location.+defaultUserLocation :: UserLocation+defaultUserLocation =+  UserLocation+    { approximate = ApproximateLocation {locationType = "approximate"}+    }++-- | Default audio configuration.+defaultAudioConfig :: AudioConfig+defaultAudioConfig =+  AudioConfig+    { format = "mp3"+    , voice = "en-US"+    }++-- | Default tool choice (None).+defaultToolChoice :: ToolChoice+defaultToolChoice = None++-- | Default specific tool choice.+defaultSpecificToolChoice :: SpecificToolChoice+defaultSpecificToolChoice =+  SpecificToolChoice+    { specificToolChoiceToolType = "text"+    , specificToolChoiceFunction = Null+    }++-- | Default reasoning effort (Low).+defaultReasoningEffort :: ReasoningEffort+defaultReasoningEffort = Low++-- | Default function.+defaultFunction :: Function_+defaultFunction =+  Function_+    { functionName = "default_function"+    , description = Nothing+    , parameters = Nothing+    , strict = Nothing+    }

@@ -38,11 +38,13 @@ streamResult <- stream ollamaLLM messages streamHandler Nothing @ -}-module Langchain.LLM.Ollama (Ollama (..)) where+module Langchain.LLM.Ollama (Ollama (..), OllamaParams(..), defaultOllamaParams) where +import Data.Aeson import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Ollama.Chat as OllamaChat+import qualified Data.Ollama.Common.Types as O import qualified Data.Ollama.Generate as OllamaGenerate import Data.Text (Text) import Langchain.Callback (Callback, Event (..))@@ -70,6 +72,34 @@ instance Show Ollama where   show (Ollama modelName _) = "Ollama " ++ show modelName +-- | Ollama Params contains same fields GenerateOps and ChatOps from [ollama-haskell](https://hackage.haskell.org/package/ollama-haskell)+data OllamaParams = OllamaParams+  { suffix :: Maybe Text+  -- ^ An optional suffix to append to the generated text.+  , images :: Maybe [Text]+  -- ^ Optional list of base64 encoded images to include with the request.+  , format :: Maybe O.Format+  -- ^ An optional format specifier for the response.+  , system :: Maybe Text+  -- ^ Optional system text that can be included in the generation context.+  , template :: Maybe Text+  -- ^ An optional streaming function where the first function handles each chunk of response, and the second flushes the stream.+  -- ^ This will not work for chat and stream, use promptTemplate instead+  , raw :: Maybe Bool+  -- ^ An optional flag to return the raw response.+  , keepAlive :: Maybe Text+  -- ^ Optional text to specify keep-alive behavior.+  , hostUrl :: Maybe Text+  -- ^ Override default Ollama host url. Default url = "http://127.0.0.1:11434"+  , responseTimeOut :: Maybe Int+  -- ^ Override default response timeout in minutes. Default = 15 minutes+  , options :: Maybe Value+  -- ^ additional model parameters listed in the documentation for the Modelfile such as temperature+  , tools :: Maybe [Value]+  -- ^ Optional tools that may be used in the chat. Will only work for chat and stream and not Generate.+  }+  deriving (Eq, Show)+ {- | Ollama implementation of the LLM typeclass Note: Params argument is currently ignored (see TODOs). @@ -83,6 +113,8 @@ @ -} instance LLM Ollama where+  type LLMParams Ollama = OllamaParams+   -- \| Generate text from a prompt   --  Returns Left on API errors, Right on success.   --@@ -90,7 +122,7 @@   --  >>> generate (Ollama "llama3.2" []) "Hello" Nothing   --  Right "Hello! How can I assist you today?"   ---  generate (Ollama model cbs) prompt _ = do+  generate (Ollama model cbs) prompt mbOllamaParams = do     mapM_ (\cb -> cb LLMStart) cbs     eRes <-       OllamaGenerate.generate@@ -98,6 +130,16 @@           { OllamaGenerate.modelName = model           , OllamaGenerate.prompt = prompt           , OllamaGenerate.stream = Nothing+          , OllamaGenerate.suffix = maybe Nothing suffix mbOllamaParams+          , OllamaGenerate.images = maybe Nothing images mbOllamaParams+          , OllamaGenerate.format = maybe Nothing format mbOllamaParams+          , OllamaGenerate.system = maybe Nothing system mbOllamaParams+          , OllamaGenerate.template = maybe Nothing template mbOllamaParams+          , OllamaGenerate.raw = maybe Nothing raw mbOllamaParams+          , OllamaGenerate.keepAlive = maybe Nothing keepAlive mbOllamaParams+          , OllamaGenerate.hostUrl = maybe Nothing hostUrl mbOllamaParams+          , OllamaGenerate.responseTimeOut = maybe Nothing responseTimeOut mbOllamaParams+          , OllamaGenerate.options = maybe Nothing options mbOllamaParams           }     case eRes of       Left err -> do@@ -115,7 +157,7 @@   --  >>> chat (Ollama "llama3" []) msgs Nothing   --  Right "How are you today?"   ---  chat (Ollama model cbs) messages _ = do+  chat (Ollama model cbs) messages mbOllamaParams = do     mapM_ (\cb -> cb LLMStart) cbs     eRes <-       OllamaChat.chat@@ -123,6 +165,12 @@           { OllamaChat.chatModelName = model           , OllamaChat.messages = toOllamaMessages messages           , OllamaChat.stream = Nothing+          , OllamaChat.tools = maybe Nothing tools mbOllamaParams+          , OllamaChat.format = maybe Nothing format mbOllamaParams+          , OllamaChat.keepAlive = maybe Nothing keepAlive mbOllamaParams+          , OllamaChat.hostUrl = maybe Nothing hostUrl mbOllamaParams+          , OllamaChat.responseTimeOut = maybe Nothing responseTimeOut mbOllamaParams+          , OllamaChat.options = maybe Nothing options mbOllamaParams           }     case eRes of       Left err -> do@@ -142,7 +190,7 @@   --  >>> stream (Ollama "llama3" []) messages handler Nothing   --  Token: H Token: i Complete   ---  stream (Ollama model_ cbs) messages StreamHandler {onToken, onComplete} _ = do+  stream (Ollama model_ cbs) messages StreamHandler {onToken, onComplete} mbOllamaParams = do     mapM_ (\cb -> cb LLMStart) cbs     eRes <-       OllamaChat.chat@@ -150,6 +198,12 @@           { OllamaChat.chatModelName = model_           , OllamaChat.messages = toOllamaMessages messages           , OllamaChat.stream = Just (onToken . chatRespToText, onComplete)+          , OllamaChat.tools = maybe Nothing tools mbOllamaParams+          , OllamaChat.format = maybe Nothing format mbOllamaParams+          , OllamaChat.keepAlive = maybe Nothing keepAlive mbOllamaParams+          , OllamaChat.hostUrl = maybe Nothing hostUrl mbOllamaParams+          , OllamaChat.responseTimeOut = maybe Nothing responseTimeOut mbOllamaParams+          , OllamaChat.options = maybe Nothing options mbOllamaParams           }     case eRes of       Left err -> do@@ -179,16 +233,29 @@     toOllamaRole System = OllamaChat.System     toOllamaRole Assistant = OllamaChat.Assistant     toOllamaRole Tool = OllamaChat.Tool+    toOllamaRole _ = OllamaChat.User -- Ollama only supports above 4 Roles, others will be defaulted to user  instance Run.Runnable Ollama where-  type RunnableInput Ollama = ChatMessage+  type RunnableInput Ollama = (ChatMessage, Maybe OllamaParams)   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+  invoke = uncurry . chat ++-- | Default values for OllamaParams+defaultOllamaParams :: OllamaParams+defaultOllamaParams = OllamaParams+  { suffix = Nothing+  , images = Nothing+  , format = Nothing+  , system = Nothing+  , template = Nothing+  , raw = Nothing+  , keepAlive = Nothing+  , hostUrl = Nothing+  , responseTimeOut = Nothing+  , options = Nothing+  , tools = Nothing+  }  {- $examples Test case patterns:

@@ -1,870 +1,338 @@-{-# 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 <tusharadhatrao@gmail.com>-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)-        }+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}++{- |+Module      : Langchain.LLM.OpenAI+Description : OpenAI integration for LangChain Haskell+Copyright   : (c) 2025 Tushar Adhatrao+License     : MIT+Maintainer  : Tushar Adhatrao <tusharadhatrao@gmail.com>+Stability   : experimental++This module provides the 'OpenAI' data type and implements the 'LLM' typeclass for interacting with OpenAI's language models.+It supports generating text, handling chat interactions, and streaming responses using OpenAI's API.++The 'OpenAI' type encapsulates the API key, model name, and callbacks for event handling.+The 'LLM' instance methods ('generate', 'chat', 'stream') allow for seamless integration with LangChain's processing pipelines.++For more information on OpenAI's API, see: <https://platform.openai.com/docs/api-reference>++@+import Data.Text (Text)+import qualified Langchain.LLM.Core as LLM+import Langchain.LLM.OpenAI (OpenAI(..))++main :: IO()+main = do+  let openAI = OpenAI+        { apiKey = "your-api-key"+        , openAIModelName = "gpt-3.5-turbo"+        , callbacks = []+        }+  result <- LLM.generate openAI "Tell me a joke" Nothing+  case result of+    Left err -> putStrLn $ "Error: " ++ err+    Right response -> putStrLn response+@+-}+module Langchain.LLM.OpenAI+  ( +    -- * Types+    OpenAI (..)+  , OpenAIParams (..)+    -- * Default functions+  , defaultOpenAIParams+  ) where++import qualified Data.List.NonEmpty as NE+import Data.Map (Map)+import Data.Maybe (fromMaybe, listToMaybe)+import Data.Text (Text)+import Langchain.Callback (Callback)+import qualified Langchain.LLM.Core as LLM+import qualified Langchain.LLM.Internal.OpenAI as OpenAI+import qualified Langchain.Runnable.Core as Run++{- | Configuration for OpenAI's language models.++This data type holds the necessary information to interact with OpenAI's API,+including the API key, the model name, and a list of callbacks for handling events.+-}+data OpenAI = OpenAI+  { apiKey :: Text+  -- ^ The API key for authenticating with OpenAI's services.+  , openAIModelName :: Text+  -- ^ The name of the OpenAI model to use (e.g., "gpt-3.5-turbo", "gpt-4").+  , callbacks :: [Callback]+  -- ^ A list of callbacks for handling events during LLM operations.+  }++-- | Not including API key to avoid accidental leak+instance Show OpenAI where+  show OpenAI {..} = "OpenAI " ++ show openAIModelName++{- | Implementation of the 'LLM' typeclass for OpenAI models.++This instance provides methods for generating text, handling chat interactions,+and streaming responses using OpenAI's API.+-}+instance LLM.LLM OpenAI where+  type LLMParams OpenAI = OpenAIParams++  generate OpenAI {..} prompt mbOpenAIParams = do+    eRes <-+      OpenAI.createChatCompletion+        apiKey+        ( OpenAI.defaultChatCompletionRequest+            { OpenAI.model = openAIModelName+            , OpenAI.messages =+                [OpenAI.defaultMessage {OpenAI.content = Just (OpenAI.StringContent prompt)}]+            , OpenAI.timeout = maybe Nothing timeout mbOpenAIParams+            , OpenAI.frequencyPenalty = maybe Nothing frequencyPenalty mbOpenAIParams+            , OpenAI.logitBias = maybe Nothing logitBias mbOpenAIParams+            , OpenAI.logprobs = maybe Nothing logprobs mbOpenAIParams+            , OpenAI.maxCompletionTokens = maybe Nothing maxCompletionTokens mbOpenAIParams+            , OpenAI.maxTokens = maybe Nothing maxTokens mbOpenAIParams+            , OpenAI.metadata = maybe Nothing metadata mbOpenAIParams+            , OpenAI.modalities = maybe Nothing modalities mbOpenAIParams+            , OpenAI.n = maybe Nothing n mbOpenAIParams+            , OpenAI.parallelToolCalls = maybe Nothing parallelToolCalls mbOpenAIParams+            , OpenAI.prediction = maybe Nothing prediction mbOpenAIParams+            , OpenAI.presencePenalty = maybe Nothing presencePenalty mbOpenAIParams+            , OpenAI.reasoningEffort = maybe Nothing reasoningEffort mbOpenAIParams+            , OpenAI.responseFormat = maybe Nothing responseFormat mbOpenAIParams+            , OpenAI.seed = maybe Nothing seed mbOpenAIParams+            , OpenAI.serviceTier = maybe Nothing serviceTier mbOpenAIParams+            , OpenAI.stop = maybe Nothing stop mbOpenAIParams+            , OpenAI.store = maybe Nothing store mbOpenAIParams+            , OpenAI.temperature = maybe Nothing temperature mbOpenAIParams+            , OpenAI.toolChoice = maybe Nothing toolChoice mbOpenAIParams+            , OpenAI.tools = maybe Nothing tools mbOpenAIParams+            , OpenAI.topLogprobs = maybe Nothing topLogprobs mbOpenAIParams+            , OpenAI.topP = maybe Nothing topP mbOpenAIParams+            , OpenAI.user = maybe Nothing user mbOpenAIParams+            , OpenAI.webSearchOptions = maybe Nothing webSearchOptions mbOpenAIParams+            , OpenAI.audio = maybe Nothing audio mbOpenAIParams+            }+        )+    case eRes of+      Left err -> return $ Left err+      Right r -> do+        case listToMaybe ((\OpenAI.ChatCompletionResponse {..} -> choices) r) of+          Nothing -> return $ Left "Did not received any response"+          Just resp ->+            let OpenAI.Message {..} = OpenAI.message resp+             in pure $+                  Right $+                    maybe+                      ""+                      ( \c -> case c of+                          OpenAI.StringContent t -> t+                          OpenAI.ContentParts _ -> ""+                      )+                      content+  chat OpenAI {..} msgs mbOpenAIParams = do+    eRes <-+      OpenAI.createChatCompletion+        apiKey+        ( OpenAI.defaultChatCompletionRequest+            { OpenAI.model = openAIModelName+            , OpenAI.messages = toOpenAIMessages msgs+            , OpenAI.timeout = maybe Nothing timeout mbOpenAIParams+            , OpenAI.frequencyPenalty = maybe Nothing frequencyPenalty mbOpenAIParams+            , OpenAI.logitBias = maybe Nothing logitBias mbOpenAIParams+            , OpenAI.logprobs = maybe Nothing logprobs mbOpenAIParams+            , OpenAI.maxCompletionTokens = maybe Nothing maxCompletionTokens mbOpenAIParams+            , OpenAI.maxTokens = maybe Nothing maxTokens mbOpenAIParams+            , OpenAI.metadata = maybe Nothing metadata mbOpenAIParams+            , OpenAI.modalities = maybe Nothing modalities mbOpenAIParams+            , OpenAI.n = maybe Nothing n mbOpenAIParams+            , OpenAI.parallelToolCalls = maybe Nothing parallelToolCalls mbOpenAIParams+            , OpenAI.prediction = maybe Nothing prediction mbOpenAIParams+            , OpenAI.presencePenalty = maybe Nothing presencePenalty mbOpenAIParams+            , OpenAI.reasoningEffort = maybe Nothing reasoningEffort mbOpenAIParams+            , OpenAI.responseFormat = maybe Nothing responseFormat mbOpenAIParams+            , OpenAI.seed = maybe Nothing seed mbOpenAIParams+            , OpenAI.serviceTier = maybe Nothing serviceTier mbOpenAIParams+            , OpenAI.stop = maybe Nothing stop mbOpenAIParams+            , OpenAI.store = maybe Nothing store mbOpenAIParams+            , OpenAI.temperature = maybe Nothing temperature mbOpenAIParams+            , OpenAI.toolChoice = maybe Nothing toolChoice mbOpenAIParams+            , OpenAI.tools = maybe Nothing tools mbOpenAIParams+            , OpenAI.topLogprobs = maybe Nothing topLogprobs mbOpenAIParams+            , OpenAI.topP = maybe Nothing topP mbOpenAIParams+            , OpenAI.user = maybe Nothing user mbOpenAIParams+            , OpenAI.webSearchOptions = maybe Nothing webSearchOptions mbOpenAIParams+            , OpenAI.audio = maybe Nothing audio mbOpenAIParams+            }+        )+    case eRes of+      Left err -> return $ Left err+      Right r -> do+        case listToMaybe ((\OpenAI.ChatCompletionResponse {..} -> choices) r) of+          Nothing -> return $ Left "Did not received any response"+          Just resp ->+            let OpenAI.Message {..} = OpenAI.message resp+             in pure $+                  Right $+                    maybe+                      ""+                      ( \c -> case c of+                          OpenAI.StringContent t -> t+                          OpenAI.ContentParts _ -> ""+                      )+                      content++  stream OpenAI {..} msgs LLM.StreamHandler {onComplete, onToken} mbOpenAIParams = do+    let req =+          OpenAI.defaultChatCompletionRequest+            { OpenAI.model = openAIModelName+            , OpenAI.messages = toOpenAIMessages msgs+            , OpenAI.stream = Just True -- Enable streaming'+            , OpenAI.timeout = maybe Nothing timeout mbOpenAIParams+            , OpenAI.frequencyPenalty = maybe Nothing frequencyPenalty mbOpenAIParams+            , OpenAI.logitBias = maybe Nothing logitBias mbOpenAIParams+            , OpenAI.logprobs = maybe Nothing logprobs mbOpenAIParams+            , OpenAI.maxCompletionTokens = maybe Nothing maxCompletionTokens mbOpenAIParams+            , OpenAI.maxTokens = maybe Nothing maxTokens mbOpenAIParams+            , OpenAI.metadata = maybe Nothing metadata mbOpenAIParams+            , OpenAI.modalities = maybe Nothing modalities mbOpenAIParams+            , OpenAI.n = maybe Nothing n mbOpenAIParams+            , OpenAI.parallelToolCalls = maybe Nothing parallelToolCalls mbOpenAIParams+            , OpenAI.prediction = maybe Nothing prediction mbOpenAIParams+            , OpenAI.presencePenalty = maybe Nothing presencePenalty mbOpenAIParams+            , OpenAI.reasoningEffort = maybe Nothing reasoningEffort mbOpenAIParams+            , OpenAI.responseFormat = maybe Nothing responseFormat mbOpenAIParams+            , OpenAI.seed = maybe Nothing seed mbOpenAIParams+            , OpenAI.serviceTier = maybe Nothing serviceTier mbOpenAIParams+            , OpenAI.stop = maybe Nothing stop mbOpenAIParams+            , OpenAI.store = maybe Nothing store mbOpenAIParams+            , OpenAI.temperature = maybe Nothing temperature mbOpenAIParams+            , OpenAI.toolChoice = maybe Nothing toolChoice mbOpenAIParams+            , OpenAI.tools = maybe Nothing tools mbOpenAIParams+            , OpenAI.topLogprobs = maybe Nothing topLogprobs mbOpenAIParams+            , OpenAI.topP = maybe Nothing topP mbOpenAIParams+            , OpenAI.user = maybe Nothing user mbOpenAIParams+            , OpenAI.webSearchOptions = maybe Nothing webSearchOptions mbOpenAIParams+            , OpenAI.audio = maybe Nothing audio mbOpenAIParams+            }+    OpenAI.createChatCompletionStream+      apiKey+      req+      OpenAI.OpenAIStreamHandler+        { OpenAI.onComplete = onComplete+        , OpenAI.onToken = onToken . chunkToText+        }+    where+      chunkToText :: OpenAI.ChatCompletionChunk -> Text+      chunkToText OpenAI.ChatCompletionChunk {..} = do+        case listToMaybe chunkChoices of+          Nothing -> ""+          Just OpenAI.ChunkChoice {..} ->+            fromMaybe "" ((\OpenAI.Delta {..} -> contentForDelta) delta)++toOpenAIMessages :: LLM.ChatMessage -> [OpenAI.Message]+toOpenAIMessages msgs = map go (NE.toList msgs)+  where+    toRole :: LLM.Role -> OpenAI.Role+    toRole r = case r of+      LLM.System -> OpenAI.System+      LLM.User -> OpenAI.User+      LLM.Assistant -> OpenAI.Assistant+      LLM.Tool -> OpenAI.Tool+      LLM.Developer -> OpenAI.Developer+      LLM.Function -> OpenAI.Function++    go :: LLM.Message -> OpenAI.Message+    go msg =+      OpenAI.defaultMessage+        { OpenAI.role = toRole $ LLM.role msg+        , OpenAI.content = Just $ OpenAI.StringContent (LLM.content msg)+        }++instance Run.Runnable OpenAI where+  type RunnableInput OpenAI = (LLM.ChatMessage, Maybe OpenAIParams)+  type RunnableOutput OpenAI = Text++  invoke = uncurry . LLM.chat++-- | Parameters for customizing OpenAI API calls.+data OpenAIParams = OpenAIParams+  { timeout :: Maybe Int+  , frequencyPenalty :: Maybe Double+  , logitBias :: Maybe (Map Text Double)+  , logprobs :: Maybe Bool+  , maxCompletionTokens :: Maybe Int+  , maxTokens :: Maybe Int+  , metadata :: Maybe (Map Text Text)+  , modalities :: Maybe [OpenAI.Modality]+  , n :: Maybe Int+  , parallelToolCalls :: Maybe Bool+  , prediction :: Maybe OpenAI.PredictionOutput+  , presencePenalty :: Maybe Double+  , reasoningEffort :: Maybe OpenAI.ReasoningEffort+  , responseFormat :: Maybe OpenAI.ResponseFormat+  , seed :: Maybe Int+  , serviceTier :: Maybe Text+  , stop :: Maybe (Either Text [Text])+  , store :: Maybe Bool+  , temperature :: Maybe Double+  , toolChoice :: Maybe OpenAI.ToolChoice+  , tools :: Maybe [OpenAI.Tool_]+  , topLogprobs :: Maybe Int+  , topP :: Maybe Double+  , user :: Maybe Text+  , webSearchOptions :: Maybe OpenAI.WebSearchOptions+  , audio :: Maybe OpenAI.AudioConfig+  }++-- | Default parameters for OpenAI API calls.+defaultOpenAIParams :: OpenAIParams+defaultOpenAIParams =+  OpenAIParams+    { timeout = Just 60+    , 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+    , temperature = Nothing+    , toolChoice = Nothing+    , tools = Nothing+    , topLogprobs = Nothing+    , topP = Nothing+    , user = Nothing+    , webSearchOptions = Nothing+    , audio = Nothing+    }++{-+ghci> :set -XOverloadedStrings+ghci> let o = OpenAI { apiKey = <my api key>+    , openAIModelName = "gpt-4.1-nano"+    , Langchain.LLM.OpenAI.callbacks = []+    }+ghci> eRes <- generate o "What is 2+2" Nothing+ghci> eRes+Right "2 + 2 equals 4."+ghci> import qualified Data.List.NonEmpty as NE+ghci> let msg = Langchain.LLM.Core.Message Langchain.LLM.Core.User "What is 2+2" defaultMessageData+ghci> let chatMsg = NE.fromList [msg]+ghci> eRes <- chat o chatMsg Nothing+ghci> eRes+Right "2 + 2 equals 4."+-}

@@ -73,6 +73,8 @@ {- | Sliding window memory implementation. Stores chat history with maximum size limit. +Note: This implementation will not trim system messages.+ Example:  >>> let mem = WindowBufferMemory 2 (NE.singleton (Message System "Sys" defaultMessageData))@@ -82,8 +84,9 @@ data WindowBufferMemory = WindowBufferMemory   { maxWindowSize :: Int   -- ^ Maximum number of messages to retain+  -- ^ It is user's responsiblity to make sure the number is > 0.   , windowBufferMessages :: ChatMessage-  -- ^ Current message buffer [[9]]+  -- ^ Current message buffer    }   deriving (Show, Eq) @@ -108,24 +111,26 @@   --  >>> 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-                  }+  addMessage winBuffMem@WindowBufferMemory{..} newMsg = do+    let currentMsgs = NE.toList windowBufferMessages+        newMsgs = currentMsgs ++ [newMsg] +    if length newMsgs > maxWindowSize+        then do+            let trimmedMsgs = removeOldestNonSystem newMsgs+            pure $ Right $ winBuffMem { windowBufferMessages = NE.fromList trimmedMsgs }+        else+            pure $ Right $ winBuffMem { windowBufferMessages = NE.fromList newMsgs }+    where+      isSystem (Message role _ _) = role == System+      +      removeOldestNonSystem = go+        where+          go [] = []+          go (m:ms)+            | isSystem m = m : go ms+            | otherwise = ms+   -- \| Add user message   --   --  Example:@@ -179,7 +184,7 @@ [msg1, msg2] -} addAndTrim :: Int -> Message -> ChatMessage -> ChatMessage-addAndTrim n msg msgs = trimChatMessage n (msgs `NE.append` NE.singleton msg)+addAndTrim n msg msgs = trimChatMessage n (msgs <> NE.singleton msg)  {- | Create initial chat history Example:

@@ -0,0 +1,90 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++{- |+Module      : Langchain.Memory.TokenBufferMemory+Description : Token based Memory management for LangChain Haskell+Copyright   : (c) 2025 Tushar Adhatrao+License     : MIT+Maintainer  : Tushar Adhatrao <tusharadhatrao@gmail.com>+Stability   : experimental++Implementation of LangChain's Conversation token buffer.+https://python.langchain.com/v0.1/docs/modules/memory/types/token_buffer/+-}+module Langchain.Memory.TokenBufferMemory (TokenBufferMemory (..), countTokens) where++import qualified Data.List.NonEmpty as NE+import qualified Data.Text as T+import Langchain.LLM.Core (ChatMessage, Message (..), Role (..), defaultMessageData)+import Langchain.Memory.Core+import Langchain.Runnable.Core (Runnable (..))++-- | Token based sliding window memory type+data TokenBufferMemory = TokenBufferMemory+  { maxTokens :: Int+  -- ^ Max number of tokens. 4 characters = 1 Token+  , tokenBufferMessages :: ChatMessage+  -- ^ Chat history (Nonempty List of Message)+  }+  deriving (Eq, Show)++{- | Function for counting tokens for the given list of messages+| 1 token = 4 characters+-}+countTokens :: [Message] -> Int+countTokens = sum . map go+  where+    go :: Message -> Int+    go (Message _ content _) = ceiling @Double (fromIntegral (T.length content) / 4.0)++instance BaseMemory TokenBufferMemory where+  messages TokenBufferMemory {..} = pure $ Right tokenBufferMessages+  addMessage t@TokenBufferMemory {..} newMsg = do+    let newMsgTokenCount = countTokens [newMsg]+        currentMsgsTokenCount = countTokens $ NE.toList tokenBufferMessages +    if newMsgTokenCount > maxTokens then +      pure (Left "New message is exceeding limit")+    else if newMsgTokenCount + currentMsgsTokenCount <= maxTokens then +      pure (Right $ t { tokenBufferMessages = tokenBufferMessages <> NE.fromList [newMsg] })+    else trimNonSystemMsgs (NE.toList tokenBufferMessages) newMsgTokenCount+    where+      trimNonSystemMsgs msgs newMsgTokenCount = do+        let trimmedMsgs = removeOldestNonSystem msgs+        if trimmedMsgs == msgs then -- If no more non sys msg left+          pure (Left "Cannot add new message since system message and new message excedds limit")+        else+          if countTokens trimmedMsgs + newMsgTokenCount <= maxTokens then +            pure (Right $ t { tokenBufferMessages = NE.fromList $ trimmedMsgs <> [newMsg] })+          else trimNonSystemMsgs trimmedMsgs newMsgTokenCount+      +      removeOldestNonSystem = go+        where+         go [] = []+         go (m:ms)+            | isSystem m = m : go ms+            | otherwise = ms++      isSystem (Message role _ _) = role == System++  addUserMessage tokBuffMem uMsg =+    addMessage tokBuffMem (Message User uMsg defaultMessageData)++  addAiMessage tokBuffMem uMsg =+    addMessage tokBuffMem (Message Assistant uMsg defaultMessageData)++  clear tokBuffMem =+    pure $+      Right $+        tokBuffMem+          { tokenBufferMessages =+              NE.singleton $ Message System "You are an AI model" defaultMessageData+          }++instance Runnable TokenBufferMemory where+  type RunnableInput TokenBufferMemory = T.Text+  type RunnableOutput TokenBufferMemory = TokenBufferMemory++  invoke memory input = addUserMessage memory input

@@ -29,7 +29,7 @@   ) where  import Data.Aeson-import Data.ByteString.Char8 (fromStrict)+import Data.ByteString.Lazy.Char8 (fromStrict) import Data.Char (isDigit, isSpace) import Data.Text (Text) import qualified Data.Text as T

@@ -8,6 +8,8 @@ License     : MIT Maintainer  : Tushar Adhatrao <tusharadhatrao@gmail.com> +Note: This module is not functional at this moment.+ This module provides the 'ConversationChain' implementation, which manages stateful conversations with language models. It combines: 

@@ -1,5 +1,4 @@ {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}  {- | Module      : Langchain.Runnable.Core

@@ -0,0 +1,113 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}++module Langchain.Tool.Calculator+  ( CalculatorTool(..)+  , Expr (..)+  , parseExpression+  , evaluateExpression+  ) where++import Data.Text (Text)+import qualified Data.Text as T+import Text.ParserCombinators.Parsec+import Langchain.Tool.Core (Tool(..))+import Control.Monad (void)++-- | Expression data type for our calculator+data Expr+  = Number_ Double+  | Add Expr Expr+  | Sub Expr Expr+  | Mul Expr Expr+  | Div Expr Expr+  | Pow Expr Expr+  deriving (Show, Eq)++-- | Calculator Tool implementation+data CalculatorTool = CalculatorTool+  deriving (Show)++instance Tool CalculatorTool where+  type Input CalculatorTool = Text+  type Output CalculatorTool = Either String Double+  +  toolName _ = "calculator"+  +  toolDescription _ = "A calculator tool that can perform basic arithmetic operations. " <>+                     "Input should be a mathematical expression like '2 + 3 * 4'."+  +  runTool _ input = do+    case parseExpression input of+      Left err -> return $ Left $ "Failed to parse expression: " ++ show err+      Right expr -> return $ Right $ evaluateExpression expr++-- | Parse a mathematical expression from Text+parseExpression :: Text -> Either ParseError Expr+parseExpression = parse expr "" . T.unpack+  where+    expr = addSubExpr++    addSubExpr = do+      left <- mulDivExpr+      rest left+      where+        rest left = +          (do+            void $ char '+' <* spaces+            right <- mulDivExpr+            rest (Add left right))+          <|> +          (do+            void $ char '-' <* spaces+            right <- mulDivExpr+            rest (Sub left right))+          <|> return left++    mulDivExpr = do+      left <- powExpr+      rest left+      where+        rest left = +          (do+            void $ char '*' <* spaces+            right <- powExpr+            rest (Mul left right))+          <|> +          (do+            void $ char '/' <* spaces+            right <- powExpr+            rest (Div left right))+          <|> return left++    powExpr = do+      left <- factor+      rest left+      where+        rest left = +          (do+            void $ char '^' <* spaces+            right <- factor+            rest (Pow left right))+          <|> return left++    factor = +      (Number_ . read <$> numberStr)+      <|> +      (spaces *> char '(' *> spaces *> expr <* spaces <* char ')' <* spaces)+      +    numberStr = do+      i <- many1 digit+      d <- option "" $ (:) <$> char '.' <*> many1 digit+      spaces+      return (i ++ d)++-- | Evaluate a parsed expression to a Double+evaluateExpression :: Expr -> Double+evaluateExpression expr = case expr of+  Number_ n -> n+  Add a b -> evaluateExpression a + evaluateExpression b+  Sub a b -> evaluateExpression a - evaluateExpression b+  Mul a b -> evaluateExpression a * evaluateExpression b+  Div a b -> evaluateExpression a / evaluateExpression b+  Pow a b -> evaluateExpression a ** evaluateExpression b

@@ -14,7 +14,7 @@  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+The design mirrors LangChain's Python tooling system while maintaining Haskell's type safety and functional programming principles.  Example use case:

@@ -0,0 +1,98 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module      : Langchain.Tool.Utils+Description : Tool for scrapping text content from URL+Copyright   : (c) 2025 Tushar Adhatrao+License     : MIT+Maintainer  : Tushar Adhatrao <tusharadhatrao@gmail.com>+Stability   : experimental++Common utility functions for Tool modules+-}+module Langchain.Tool.Utils (cleanBodyContent, cleanHtmlContent) where++import qualified Data.List as L+import Data.Maybe (catMaybes)+import Data.Text (Text)+import qualified Text.HTML.TagSoup as TS+import qualified Text.StringLike as TS++-- | This function takes a text that contains html tags, and removes them while preserving links+cleanHtmlContent :: Text -> Text+cleanHtmlContent c = extractText (TS.parseTags c)++-- | Clean the HTML content: extract body, remove scripts, and strip attributes+cleanBodyContent :: [TS.Tag Text] -> Text+cleanBodyContent tags =+  let -- Extract only body content+      bodyTags = case TS.partitions (TS.isTagOpenName "body") tags of+        [] -> tags -- If no body tag is found, use all tags+        (bodySection : _) -> bodySection+      filteredTags = removeTags bodyTags+      content = extractText filteredTags+   in content++{-+If the tag is <a> anchor tag, then extract and append the link as well.+-}+extractText :: [TS.Tag Text] -> Text+extractText ts = TS.strConcat $ catMaybes (go ts)+  where+    go [] = []+    go ((TS.TagOpen "a" aAttrList) : xs) =+      ( Just "link: "+          <> L.lookup "href" aAttrList+          <> Just " for:"+      )+        : go xs+    go (x : xs) = TS.maybeTagText x : go xs++allowedTags :: [TS.Tag Text -> Bool]+allowedTags =+  textTag+    : ( mkIsTag+          <$> [ "p"+              , "button"+              , "a"+              , "div"+              , "h1"+              , "h2"+              , "h3"+              , "h4"+              , "h5"+              , "h6"+              , "span"+              , "ul"+              , "li"+              , "input"+              , "submit"+              , "label"+              , "option"+              , "select"+              , "textarea"+              , "blockquote"+              , "pre"+              , "code"+              , "strong"+              , "em"+              , "b"+              , "i"+              , "u"+              , "mark"+              , "small"+              , "big"+              ]+      )+  where+    textTag (TS.TagText _) = True+    textTag _ = False+    mkIsTag name tag = isTag tag name++isTag :: TS.Tag Text -> Text -> Bool+isTag (TS.TagOpen name _) t = name == t+isTag (TS.TagClose name) t = name == t+isTag _ _ = False++removeTags :: [TS.Tag Text] -> [TS.Tag Text]+removeTags = filter (\t -> any (\f -> f t) allowedTags)

@@ -9,6 +9,10 @@ License     : MIT Maintainer  : Tushar Adhatrao <tusharadhatrao@gmail.com> Stability   : experimental++WebScraper is a tool that scrapes text content from a given URL.+It fetches the HTML content of the page, extracts the body text, removes scripts, and strips class/id/style attributes from the HTML tags.+It is designed to be used with the Langchain framework for building language models and applications. -} module Langchain.Tool.WebScraper (WebScraper (..), WebPageInfo (..), fetchAndScrape) where @@ -21,8 +25,9 @@ import qualified Data.Text.Encoding as TE import GHC.Generics (Generic) import Langchain.Tool.Core+import Langchain.Tool.Utils import Network.HTTP.Simple-import Text.HTML.Scalpel+import qualified Text.HTML.TagSoup as TS  -- | Represents a web scraper tool that extracts content from web pages data WebScraper = WebScraper@@ -31,9 +36,7 @@ -- | Stores the extracted webpage information data WebPageInfo = WebPageInfo   { pageTitle :: Maybe Text-  , pageHeadings :: [Text]-  , pageLinks :: [(Text, Text)] -- (Link text, URL)-  , pageText :: Text+  , pageContent :: Text   }   deriving (Show, Generic) @@ -46,19 +49,19 @@ -- | Implement the Tool typeclass for WebScraper instance Tool WebScraper where   type Input WebScraper = ScraperInput-  type Output WebScraper = Text+  type Output WebScraper = (Either String 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."+    "Scrapes content from a webpage. Provide a valid URL, and it will extract only the textual body content "+      <> "with scripts removed and without class/id/style attributes."    runTool _ url = do     result <- fetchAndScrape url     case result of-      Left err -> pure $ "Error scraping webpage: " <> T.pack (show err)-      Right info -> pure $ T.pack (show info)+      Left err -> pure $ Left $ "Error scraping webpage: " <> err+      Right info -> pure $ Right $ pageContent info  -- | Fetch HTML content from a URL and extract webpage information fetchAndScrape :: Text -> IO (Either String WebPageInfo)@@ -70,47 +73,20 @@     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]+      -- Clean and extract the content+      let tags = TS.parseTags htmlContent+      let title = extractTitle tags+      let cleanedContent = cleanBodyContent tags --- | 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)+      pure $ Right $ WebPageInfo title cleanedContent --- | 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]+-- | Extract the title from parsed HTML tags+extractTitle :: [TS.Tag Text] -> Maybe Text+extractTitle tags =+  let titleTags = TS.partitions (TS.isTagOpenName "title") tags+   in if null titleTags+        then Nothing+        else case listToMaybe titleTags of+          Nothing -> Nothing+          Just r -> Just $ T.strip $ TS.innerText r

@@ -42,6 +42,7 @@ import Langchain.Runnable.Core (Runnable (..)) import Langchain.Tool.Core import Network.HTTP.Simple+import Langchain.Tool.Utils (cleanHtmlContent)  {- | Wikipedia search tool configuration@@ -67,7 +68,7 @@  -- | Default value for top K defaultTopK :: Int-defaultTopK = 2+defaultTopK = 1  -- | Default value for max chars defaultDocMaxChars :: Int@@ -152,7 +153,7 @@     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+      let extracts = map (T.take (docMaxChars tool) . cleanHtmlContent . extract) pages       return $ T.intercalate "\n\n" extracts  -- | Perform a search on Wikipedia.

@@ -1,6 +1,7 @@ import qualified Test.Langchain.Agent.Core as AgentTest-import qualified Test.Langchain.Agent.ReactAgent as ReactAgentTest+-- import qualified Test.Langchain.Agent.ReactAgent as ReactAgentTest import qualified Test.Langchain.DocumentLoader.Core as DocumentLoaderTest+import qualified Test.Langchain.DocumentLoader.DirectoryLoader as DirectoryLoaderTest import qualified Test.Langchain.Embeddings.Core as EmbeddingsTest import qualified Test.Langchain.LLM.Core as LLMCoreTest import qualified Test.Langchain.LLM.Ollama as OllamaLLMTest@@ -15,6 +16,7 @@ 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 qualified Test.Langchain.Memory.TokenBufferMemory as TokenBufferMemoryTest import Test.Tasty  main :: IO ()@@ -28,15 +30,17 @@       , OutputParserTest.tests       , TextSplitterTest.tests       , DocumentLoaderTest.tests+      , DirectoryLoaderTest.tests       , MemoryTest.tests       , VectorStoreTest.tests       , EmbeddingsTest.tests       , RetrieverTest.tests       , ToolTest.tests       , AgentTest.tests-      , ReactAgentTest.tests+      -- , ReactAgentTest.tests       , RunnableTest.tests       , RunnableUtilsTest.tests       , RunnableChainsTest.tests       , ConverationChainsTest.tests+      , TokenBufferMemoryTest.tests       ]

@@ -1,134 +0,0 @@-{-# 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

@@ -0,0 +1,249 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Langchain.DocumentLoader.DirectoryLoader (tests) where++import Control.Monad (forM_)+import Data.Aeson+import Data.List (sort)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe, mapMaybe)+import qualified Data.Text as T+import System.Directory+import System.FilePath (takeDirectory, (</>))+import System.IO.Temp (withSystemTempDirectory)+import Test.Tasty+import Test.Tasty.HUnit++import Langchain.DocumentLoader.Core+import Langchain.DocumentLoader.DirectoryLoader++-- Helper Functions++-- | Creates a single file with the specified content.+createTestFile :: FilePath -> String -> IO ()+createTestFile path content = writeFile path content++-- | Creates multiple files in a directory with specified relative paths and contents.+createTestFiles :: FilePath -> [(FilePath, String)] -> IO ()+createTestFiles dir files = forM_ files $ \(relPath, content) -> do+  let fullPath = dir </> relPath+  createDirectoryIfMissing True (takeDirectory fullPath)+  createTestFile fullPath content++-- | Extracts the "source" metadata from a Document as a FilePath.+getSource :: Document -> Maybe FilePath+getSource doc = case Map.lookup "source" (metadata doc) of+  Just (String s) -> Just (T.unpack s)+  _ -> Nothing++-- Test Suite++tests :: TestTree+tests =+  testGroup+    "DirectoryLoader Tests"+    [ testBasicLoading+    , testRecursiveLoading+    , testExtensionFiltering+    , testHiddenFilesExclusion+    , testMultithreading+    , testErrorHandling+    , testLoadAndSplit+    ]++-- Test Cases++-- | Tests basic loading of files from a directory.+testBasicLoading :: TestTree+testBasicLoading = testCase "Basic loading" $+  withSystemTempDirectory "test-dir-loader" $ \dir -> do+    let file1 = dir </> "file1.txt"+        file2 = dir </> "file2.txt"+    createTestFile file1 "Content of file1"+    createTestFile file2 "Content of file2"+    let loader = DirectoryLoader dir defaultDirectoryLoaderOptions+    result <- load loader+    case result of+      Left err -> assertFailure $ "Expected Right but got Left: " ++ err+      Right docs -> do+        let docMap = Map.fromList [(fromMaybe "" (getSource d), pageContent d) | d <- docs]+            expectedMap = Map.fromList [(file1, "Content of file1"), (file2, "Content of file2")]+        docMap @?= expectedMap++-- | Tests recursive loading with different depth limits.+testRecursiveLoading :: TestTree+testRecursiveLoading = testCase "Recursive loading" $+  withSystemTempDirectory "test-dir-loader" $ \dir -> do+    createTestFiles+      dir+      [ ("file1.txt", "Content of file1")+      , ("subdir1/file2.txt", "Content of file2")+      , ("subdir1/subsubdir/file3.txt", "Content of file3")+      ]+    let allFiles = [dir </> "file1.txt", dir </> "subdir1/file2.txt", dir </> "subdir1/subsubdir/file3.txt"]+        level0Files = [dir </> "file1.txt"]+        level1Files = [dir </> "file1.txt", dir </> "subdir1/file2.txt"]+    -- Unlimited recursion+    let opts = defaultDirectoryLoaderOptions {recursiveDepth = Nothing}+        loader = DirectoryLoader dir opts+    result <- load loader+    case result of+      Left err -> assertFailure $ "Expected Right but got Left: " ++ err+      Right docs -> do+        let sources = mapMaybe getSource docs+        sort sources @?= sort allFiles+    -- No recursion (depth 0)+    let opts0 = defaultDirectoryLoaderOptions {recursiveDepth = Just 0}+        loader0 = DirectoryLoader dir opts0+    result0 <- load loader0+    case result0 of+      Left err -> assertFailure $ "Expected Right but got Left: " ++ err+      Right docs -> do+        let sources = mapMaybe getSource docs+        sort sources @?= sort level0Files+    -- Depth 1+    let opts1 = defaultDirectoryLoaderOptions {recursiveDepth = Just 1}+        loader1 = DirectoryLoader dir opts1+    result1 <- load loader1+    case result1 of+      Left err -> assertFailure $ "Expected Right but got Left: " ++ err+      Right docs -> do+        let sources = mapMaybe getSource docs+        sort sources @?= sort level1Files+    -- Depth 2+    let opts2 = defaultDirectoryLoaderOptions {recursiveDepth = Just 2}+        loader2 = DirectoryLoader dir opts2+    result2 <- load loader2+    case result2 of+      Left err -> assertFailure $ "Expected Right but got Left: " ++ err+      Right docs -> do+        let sources = mapMaybe getSource docs+        sort sources @?= sort allFiles++-- | Tests filtering files by extensions.+testExtensionFiltering :: TestTree+testExtensionFiltering = testCase "Extension filtering" $+  withSystemTempDirectory "test-dir-loader" $ \dir -> do+    createTestFiles+      dir+      [ ("file.txt", "Content of txt")+      , ("file.md", "Content of md")+      , ("file.hs", "Content of hs")+      ]+    let allFiles = [dir </> "file.txt", dir </> "file.md", dir </> "file.hs"]+        txtFiles = [dir </> "file.txt"]+        txtMdFiles = [dir </> "file.txt", dir </> "file.md"]+    -- Only .txt files+    let opts = defaultDirectoryLoaderOptions {extensions = [".txt"]}+        loader = DirectoryLoader dir opts+    result <- load loader+    case result of+      Left err -> assertFailure $ "Expected Right but got Left: " ++ err+      Right docs -> do+        let sources = mapMaybe getSource docs+        sort sources @?= sort txtFiles+    -- .txt and .md files+    let opts2 = defaultDirectoryLoaderOptions {extensions = [".txt", ".md"]}+        loader2 = DirectoryLoader dir opts2+    result2 <- load loader2+    case result2 of+      Left err -> assertFailure $ "Expected Right but got Left: " ++ err+      Right docs -> do+        let sources = mapMaybe getSource docs+        sort sources @?= sort txtMdFiles+    -- All files (empty extensions list)+    let opts3 = defaultDirectoryLoaderOptions -- { extensions = [] }+        loader3 = DirectoryLoader dir opts3+    result3 <- load loader3+    case result3 of+      Left err -> assertFailure $ "Expected Right but got Left: " ++ err+      Right docs -> do+        let sources = mapMaybe getSource docs+        sort sources @?= sort allFiles++-- | Tests exclusion of hidden files.+testHiddenFilesExclusion :: TestTree+testHiddenFilesExclusion = testCase "Hidden files exclusion" $+  withSystemTempDirectory "test-dir-loader" $ \dir -> do+    createTestFiles+      dir+      [ ("file.txt", "Content of file")+      , (".hidden.txt", "Content of hidden")+      ]+    let visibleFiles = [dir </> "file.txt"]+        allFiles = [dir </> "file.txt", dir </> ".hidden.txt"]+    -- Exclude hidden files+    let opts = defaultDirectoryLoaderOptions {excludeHidden = True}+        loader = DirectoryLoader dir opts+    result <- load loader+    case result of+      Left err -> assertFailure $ "Expected Right but got Left: " ++ err+      Right docs -> do+        let sources = mapMaybe getSource docs+        sort sources @?= sort visibleFiles+    -- Include hidden files+    let opts2 = defaultDirectoryLoaderOptions {excludeHidden = False}+        loader2 = DirectoryLoader dir opts2+    result2 <- load loader2+    case result2 of+      Left err -> assertFailure $ "Expected Right but got Left: " ++ err+      Right docs -> do+        let sources = mapMaybe getSource docs+        sort sources @?= sort allFiles++-- | Tests loading with multithreading enabled.+testMultithreading :: TestTree+testMultithreading = testCase "Multithreading" $+  withSystemTempDirectory "test-dir-loader" $ \dir -> do+    createTestFiles+      dir+      [ ("file1.txt", "Content of file1")+      , ("file2.txt", "Content of file2")+      ]+    let files = [dir </> "file1.txt", dir </> "file2.txt"]+    let opts = defaultDirectoryLoaderOptions {useMultithreading = True}+        loader = DirectoryLoader dir opts+    result <- load loader+    case result of+      Left err -> assertFailure $ "Expected Right but got Left: " ++ err+      Right docs -> do+        let sources = mapMaybe getSource docs+        sort sources @?= sort files++-- | Tests error handling for invalid directory paths.+testErrorHandling :: TestTree+testErrorHandling =+  testGroup+    "Error handling"+    [ testCase "Non-existent directory" $ do+        let loader = DirectoryLoader "non-existent-dir" defaultDirectoryLoaderOptions+        result <- load loader+        case result of+          Left err -> assertBool "Expected error message" (not $ null err)+          Right _ -> assertFailure "Expected Left but got Right"+    , testCase "Path is a file" $+        withSystemTempDirectory "test-dir-loader" $ \dir -> do+          let filePath = dir </> "testfile.txt"+          createTestFile filePath "Content"+          let loader = DirectoryLoader filePath defaultDirectoryLoaderOptions+          result <- load loader+          case result of+            Left err -> assertBool "Expected error message" (not $ null err)+            Right _ -> assertFailure "Expected Left but got Right"+    ]++-- | Tests the loadAndSplit function.+testLoadAndSplit :: TestTree+testLoadAndSplit = testCase "loadAndSplit" $+  withSystemTempDirectory "test-dir-loader" $ \dir -> do+    createTestFiles+      dir+      [ ("file1.txt", "Paragraph 1\n\nParagraph 2")+      , ("file2.txt", "Paragraph 3\n\nParagraph 4")+      ]+    let loader = DirectoryLoader dir defaultDirectoryLoaderOptions+    result <- loadAndSplit loader+    case result of+      Left err -> assertFailure $ "Expected Right but got Left: " ++ err+      Right chunks -> do+        chunks @?= ["Paragraph 3","Paragraph 4Paragraph 1","Paragraph 2"]

@@ -2,44 +2,19 @@  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+        [ testCase "Propagates API errors" $ do             let embeddings = OllamaEmbeddings "error-model" Nothing Nothing             -- Assuming embeddingOps returns Left "API Failure"             result <- embedQuery embeddings "error query"@@ -47,34 +22,4 @@               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"-                                  -}-        ]     ]-

@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}  module Test.Langchain.LLM.Core (tests) where @@ -10,6 +11,7 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (Text) import Langchain.LLM.Core+import Data.Maybe (fromMaybe)  data TestLLM = TestLLM   { responseText :: Text@@ -17,10 +19,12 @@   }  instance LLM TestLLM where-  generate m _ _ =+  type LLMParams TestLLM = Text+ +  generate m _ mbParams =     pure $       if shouldSucceed m-        then Right (responseText m)+        then Right (fromMaybe (responseText m) mbParams)         else Left "Test error"    chat m _ _ =@@ -41,22 +45,8 @@ 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+    [ +    testGroup         "Role"         [ testCase "has correct equality" $ do             assertEqual "System equals System" System System@@ -116,7 +106,13 @@         "LLM Typeclass"         [ testGroup             "generate"-            [ testCase "returns Right with response for successful generation" $ do+            [ +              testCase "generate uses provided LLMParams" $ do+            let testLLM = TestLLM { responseText = "Default", shouldSucceed = True }+            result <- generate testLLM "Prompt" (Just "CustomParam")+            assertEqual "Should return CustomParam" (Right "CustomParam") result++             , testCase "returns Right with response for successful generation" $ do                 let successLLM = TestLLM "Success response" True                 result <- generate successLLM "Test prompt" Nothing                 assertEqual "Successful generation" (Right "Success response") result@@ -124,11 +120,6 @@                 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"

@@ -11,11 +11,15 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Encoding as T  import Langchain.Callback (Callback, Event (..)) import Langchain.LLM.Core import Langchain.LLM.Ollama import qualified Langchain.Runnable.Core as Run+import qualified Data.Ollama.Common.Types as O+import Data.Aeson+import qualified Data.ByteString.Lazy.Char8 as BSL  captureEvents :: IO (Callback, IO [Event]) captureEvents = do@@ -107,10 +111,79 @@     , 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+        result <- Run.invoke ollama (input, Nothing)         case result of           Left err -> assertFailure $ "Expected success, got error: " ++ err           Right response -> assertBool "Should mention 4" ("4" `T.isInfixOf` T.toLower response)+    {- llama3.2 does not support insert+    , testCase "generate appends suffix when provided" $ do+        (callback, getEvents) <- captureEvents+        let ollama = Ollama testModelName [callback]+        let prompt = "What is functional programming?"+        let params = defaultOllamaParams { suffix = Just " [End]" }+        result <- generate ollama prompt (Just params)+        case result of+          Left err -> assertFailure $ "Expected success, got error: " ++ err+          Right response -> do+            assertBool "Response should end with suffix" (T.isSuffixOf " [End]" response)+            events <- getEvents+            assertBool "should contain all events" (events `shouldContainAll` [LLMStart, LLMEnd])+            -}+    , testCase "generate uses system message for context" $ do+        (callback, getEvents) <- captureEvents+        let ollama = Ollama testModelName [callback]+        let prompt = "Explain monads."+        let systemMsg = "You are a Haskell expert."+        let params = defaultOllamaParams { system = Just systemMsg }+        result <- generate ollama prompt (Just params)+        case result of+          Left err -> assertFailure $ "Expected success, got error: " ++ err+          Right response -> do+            assertBool "Response should mention Haskell" ("haskell" `T.isInfixOf` T.toLower response)+            events <- getEvents+            assertBool "should contain all events" (events `shouldContainAll` [LLMStart, LLMEnd])+    , testCase "generate returns JSON response when format is set" $ do+        (callback, getEvents) <- captureEvents+        let ollama = Ollama testModelName [callback]+        let prompt = "What is JSON?"+        let params = defaultOllamaParams { format = Just O.JsonFormat }+        result <- generate ollama prompt (Just params)+        case result of+          Left err -> assertFailure $ "Expected success, got error: " ++ err+          Right response -> do+            case eitherDecode (BSL.fromStrict $ T.encodeUtf8 response) :: Either String Value of+              Left _ -> assertFailure "Response is not valid JSON"+              Right _ -> return ()+            events <- getEvents+            assertBool "should contain all events" (events `shouldContainAll` [LLMStart, LLMEnd])+    , testCase "generate uses temperature option" $ do+        (callback, getEvents) <- captureEvents+        let ollama = Ollama testModelName [callback]+        let prompt = "Write a short story."+        let temp = 0.7+        let opts = object ["temperature" .= Number temp]+        let params = defaultOllamaParams { options = Just opts }+        result <- generate ollama prompt (Just params)+        case result of+          Left err -> assertFailure $ "Expected success, got error: " ++ err+          Right response -> do+            assertBool "Response should not be empty" (T.length response > 0)+            events <- getEvents+            assertBool "should contain all events" (events `shouldContainAll` [LLMStart, LLMEnd])+    , testCase "chat returns JSON response when format is set" $ do+        (callback, getEvents) <- captureEvents+        let ollama = Ollama testModelName [callback]+        let messages = Message User "What is JSON?" defaultMessageData :| []+        let params = defaultOllamaParams { format = Just O.JsonFormat }+        result <- chat ollama messages (Just params)+        case result of+          Left err -> assertFailure $ "Expected success, got error: " ++ err+          Right response -> do+            case eitherDecode (BSL.fromStrict $ T.encodeUtf8 response) :: Either String Value of+              Left _ -> assertFailure "Response is not valid JSON"+              Right _ -> return ()+            events <- getEvents+            assertBool "should contain all events" (events `shouldContainAll` [LLMStart, LLMEnd])     ]   where     isErrorEvent (LLMError _) = True

@@ -89,7 +89,7 @@               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"]+                NE.toList msgs @?= [systemMsg "System", aiMsg "AI1", userMsg "User2"]     , testCase "addUserMessage should add message with User role" $ do         let initialMsgs = NE.fromList [systemMsg "System"]             memory = WindowBufferMemory 3 initialMsgs

@@ -0,0 +1,131 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Langchain.Memory.TokenBufferMemory (tests) where++import qualified Data.List.NonEmpty as NE+import Data.Text (Text)+import qualified Data.Text as T+import Langchain.LLM.Core+import Langchain.Memory.Core (BaseMemory (..))+import qualified Langchain.Memory.TokenBufferMemory as TB+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertFailure, testCase, (@?=))+#if MIN_VERSION_base(4,19,0)+import Data.List (unsnoc)+#else+unsnoc :: [a] -> Maybe ([a], a)+unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing+#endif++mkMsg :: Role -> Text -> Message+mkMsg role1 content1 = Message role1 content1 defaultMessageData++assertRight :: Either String a -> Assertion+assertRight (Right _) = pure ()+assertRight (Left err) = error $ "Expected Right but got Left: " ++ err++assertLeft :: String -> Either String a -> Assertion+assertLeft expectedErr (Left actualErr) = actualErr @?= expectedErr+assertLeft _ (Right _) = error $ "Expected Left but got Right"++runAddAndGet :: TB.TokenBufferMemory -> [Message] -> IO ChatMessage+runAddAndGet initial msgs = do+  TB.tokenBufferMessages+    <$> foldl+      ( \mem_ msg -> do+          mem <- mem_+          eRes <- addMessage mem msg+          case eRes of+            Left _ -> pure mem+            Right r -> pure r+      )+      (pure initial)+      msgs++-- Tests+tests :: TestTree+tests =+  testGroup+    "TokenBufferMemory Tests"+    [ countTokensTests+    , addMessageTests+    , addUserAndAiMessageTests+    , clearTest+    ]++countTokensTests :: TestTree+countTokensTests =+  testGroup+    "countTokens"+    [ testCase "Empty message list" $+        TB.countTokens [] @?= 0+    , testCase "Single message" $+        TB.countTokens [mkMsg System "abc"] @?= ceiling (3 / 4 :: Double)+    , testCase "Multiple messages" $+        TB.countTokens [mkMsg User "hello", mkMsg Assistant "world"] @?= ceiling (5 / 4 :: Double) * 2+    ]++addMessageTests :: TestTree+addMessageTests =+  testGroup+    "addMessage"+    [ testCase "Add within limit" $ do+        let initial = TB.TokenBufferMemory 100 (NE.fromList [mkMsg System ""])+            newMsg = mkMsg User "content"+        updated <- runAddAndGet initial [newMsg]+        NE.length updated @?= 2+    , testCase "Exceeding token limit trims old messages" $ do+        -- Total tokens allowed: 6+        -- Each message has 3 characters ⇒ ~1 token each+        let maxTok = 2+            baseMsg = mkMsg System "aaa"+            userMsg = mkMsg User "bbb"+            aiMsg = mkMsg Assistant "ccc"++            initial = TB.TokenBufferMemory maxTok (NE.fromList [baseMsg])++        updated <- runAddAndGet initial [userMsg, aiMsg]+        NE.toList updated @?= [baseMsg, aiMsg] -- first message gets trimmed+    , testCase "New message alone exceeds limit" $ do+        let initial = TB.TokenBufferMemory 1 (NE.fromList [mkMsg System ""])+            bigMsg = mkMsg User (T.replicate 10 "a") -- 10 chars → 2.5 tokens (ceil to 3)+        result <- addMessage initial bigMsg+        assertLeft "New message is exceeding limit" result+    ]++addUserAndAiMessageTests :: TestTree+addUserAndAiMessageTests =+  testGroup+    "addUserMessage and addAiMessage"+    [ testCase "addUserMessage adds User role message" $ do+        let initial = TB.TokenBufferMemory 100 (NE.fromList [mkMsg System ""])+            userContent = "Hello!"+        updated <- addUserMessage initial userContent+        case updated of+          Right mem -> do+            let msgs = NE.toList $ TB.tokenBufferMessages mem+            unsnoc msgs @?= Just ([mkMsg System ""], mkMsg User userContent)+          Left err -> assertFailure $ "Unexpected Left: " ++ err+    , testCase "addAiMessage adds Assistant role message" $ do+        let initial = TB.TokenBufferMemory 100 (NE.fromList [mkMsg System ""])+            aiContent = "I'm an assistant."+        updated <- addAiMessage initial aiContent+        case updated of+          Right mem -> do+            let msgs = NE.toList $ TB.tokenBufferMessages mem+            unsnoc msgs @?= Just ([mkMsg System ""], mkMsg Assistant aiContent)+          Left err -> assertFailure $ "Unexpected Left: " ++ err+    ]++clearTest :: TestTree+clearTest =+  testCase "clear resets messages to default system message" $ do+    let initial = TB.TokenBufferMemory 100 (NE.fromList [mkMsg User "old"])+    cleared <- clear initial+    assertRight cleared+    case cleared of+      Right mem ->+        TB.tokenBufferMessages mem+          @?= NE.singleton (mkMsg System "You are an AI model")+      Left _ -> assertFailure "Clear failed unexpectedly"

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}  module Test.Langchain.Retriever.Core (tests) where @@ -16,6 +17,7 @@  --TODO: Add some real world examples here instance LLM DummyLLM where+  type LLMParams DummyLLM = String   -- When 'generate' is called, we return a fixed response in the format expected by the   -- NumberSeparatedList parser. For example:   --

@@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}  module Test.Langchain.Runnable.ConversationChains (tests) where @@ -54,6 +55,7 @@   }  instance LLM MockLLM where+  type LLMParams MockLLM = String   chat llm0 (msgs :: NonEmpty Message) _ = do     writeIORef (receivedMessages llm0) (NE.toList msgs)     return (llmResponse llm0)

@@ -11,10 +11,12 @@ import qualified Data.Text as T import Test.Tasty import Test.Tasty.HUnit+import Data.Either (isLeft)  import Langchain.Tool.Core import Langchain.Tool.WebScraper import Langchain.Tool.WikipediaTool+import Langchain.Tool.Calculator  data MockTool = MockTool Text   deriving (Show, Eq)@@ -37,13 +39,97 @@     , testCase "SearchResponse parsing" testSearchResponseParsing     , testCase "PageResponse parsing" testPageResponseParsing     , testCase "WebScraper Tool" testWebScraperTool+    , testCalculatorTool     ] +testCalculatorTool :: TestTree+testCalculatorTool = testGroup "Langchain.Tool.Calculator"+  [ parseExpressionTests+  , evaluateExpressionTests+  , calculatorToolTests+  ]++-- | Test cases for parseExpression+parseExpressionTests :: TestTree+parseExpressionTests = testGroup "parseExpression"+  [ testCase "Parses integer" $+      parseExpression "123" @?= Right (Number_ 123.0)++  , testCase "Parses decimal" $+      parseExpression "45.67" @?= Right (Number_ 45.67)++  , testCase "Handles addition" $+      parseExpression "2+3" @?= Right (Add (Number_ 2) (Number_ 3))++  , testCase "Handles subtraction" $+      parseExpression "5 - 1" @?= Right (Sub (Number_ 5) (Number_ 1))++  , testCase "Handles multiplication" $+      parseExpression "4*2" @?= Right (Mul (Number_ 4) (Number_ 2))++  , testCase "Handles division" $+      parseExpression "8 / 2" @?= Right (Div (Number_ 8) (Number_ 2))++  , testCase "Handles exponentiation" $+      parseExpression "2^3" @?= Right (Pow (Number_ 2) (Number_ 3))++  , testCase "Respects operator precedence" $+      parseExpression "2 + 3 * 4" @?= Right (Add (Number_ 2) (Mul (Number_ 3) (Number_ 4)))++  , testCase "Respects parentheses" $+      parseExpression "(2 + 3) * 4" @?= Right (Mul (Add (Number_ 2) (Number_ 3)) (Number_ 4))++  , testCase "Fails on invalid input" $+      isLeft (parseExpression "hello") @? "Expected parse failure for 'hello'"+  ]++-- | Test cases for evaluateExpression+evaluateExpressionTests :: TestTree+evaluateExpressionTests = testGroup "evaluateExpression"+  [ testCase "Evaluates Num" $+      evaluateExpression (Number_ 5) @?= 5.0++  , testCase "Evaluates Add" $+      evaluateExpression (Add (Number_ 2) (Number_ 3)) @?= 5.0++  , testCase "Evaluates Mul" $+      evaluateExpression (Mul (Number_ 3) (Number_ 4)) @?= 12.0++  , testCase "Evaluates Pow" $+      evaluateExpression (Pow (Number_ 2) (Number_ 3)) @?= 8.0+  ]++-- | Test cases for CalculatorTool+calculatorToolTests :: TestTree+calculatorToolTests = testGroup "CalculatorTool"+  [ testCase "Computes 2 + 3 * 4" $ do+      result <- runTool CalculatorTool "2 + 3 * 4"+      result @?= Right 14.0++  , testCase "Computes (2 + 3) * 4" $ do+      result <- runTool CalculatorTool "(2 + 3) * 4"+      result @?= Right 20.0++  , testCase "Computes 2 ^ 3" $ do+      result <- runTool CalculatorTool "2 ^ 3"+      result @?= Right 8.0++  , testCase "Fails on invalid expression" $ do+      let badExpr = "2 +"+      errOrRes <- runTool CalculatorTool badExpr+      case errOrRes of+        Left _ -> return ()+        Right _ -> assertFailure "Expected error when parsing invalid expression"+  ]+ testWebScraperTool :: Assertion testWebScraperTool = do-  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+  eRes <- runTool WebScraper "https://hackage.haskell.org/package/scalpel-0.6.2.2"+  assertBool "Scraper should contain stuff like title" $ do+    case eRes of +      Left _ -> False+      Right r -> do+        T.isInfixOf "Scalpel is a web scraping library inspired by libraries like" r  testMockTool :: Assertion testMockTool = do