langchain-hs 0.0.2.0 → 0.0.3.0

raw patch · 69 files changed

+4232/−2887 lines, 69 filesdep +base64-bytestringdep +openaidep +timedep ~ollama-haskellsetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: base64-bytestring, openai, time, transformers

Dependency ranges changed: ollama-haskell

API changes (from Hackage documentation)

Files

• CHANGELOG.md +22/−0
• README.md +6/−0
• Setup.hs +1/−0
• langchain-hs.cabal +24/−8
• src/Langchain/Agent/Core.hs +303/−0
• src/Langchain/Agent/Executor.hs +261/−0
• src/Langchain/Agent/Middleware.hs +133/−0
• src/Langchain/Agent/ReAct.hs +169/−0
• src/Langchain/Agents/Core.hs +0/−154
• src/Langchain/Agents/React.hs +0/−162
• src/Langchain/Callback.hs +1/−1
• src/Langchain/Chain/RetrievalQA.hs +3/−2
• src/Langchain/DocumentLoader/Core.hs +12/−5
• src/Langchain/DocumentLoader/DirectoryLoader.hs +27/−12
• src/Langchain/DocumentLoader/FileLoader.hs +42/−11
• src/Langchain/DocumentLoader/PdfLoader.hs +31/−11
• src/Langchain/Embeddings/Core.hs +26/−16
• src/Langchain/Embeddings/Gemini.hs +67/−0
• src/Langchain/Embeddings/Ollama.hs +36/−23
• src/Langchain/Embeddings/OpenAI.hs +46/−34
• src/Langchain/Error.hs +609/−0
• src/Langchain/LLM/Core.hs +181/−34
• src/Langchain/LLM/Deepseek.hs +67/−0
• src/Langchain/LLM/Gemini.hs +104/−0
• src/Langchain/LLM/Huggingface.hs +72/−60
• src/Langchain/LLM/Internal/Huggingface.hs +77/−34
• src/Langchain/LLM/Internal/OpenAI.hs +0/−1149
• src/Langchain/LLM/Ollama.hs +136/−152
• src/Langchain/LLM/OpenAI.hs +40/−265
• src/Langchain/LLM/OpenAICompatible.hs +403/−0
• src/Langchain/Memory/Core.hs +56/−32
• src/Langchain/Memory/TokenBufferMemory.hs +61/−21
• src/Langchain/OutputParser/Core.hs +20/−11
• src/Langchain/PromptTemplate.hs +9/−8
• src/Langchain/Retriever/Core.hs +15/−10
• src/Langchain/Retriever/MultiQueryRetriever.hs +8/−8
• src/Langchain/Runnable/Chain.hs +8/−7
• src/Langchain/Runnable/ConversationChain.hs +7/−22
• src/Langchain/Runnable/Core.hs +39/−59
• src/Langchain/Runnable/Utils.hs +4/−24
• src/Langchain/TextSplitter/Character.hs +6/−5
• src/Langchain/Tool/Calculator.hs +78/−41
• src/Langchain/Tool/Core.hs +41/−30
• src/Langchain/Tool/DuckDuckGo.hs +266/−0
• src/Langchain/Tool/Utils.hs +3/−2
• src/Langchain/Tool/WebScraper.hs +1/−1
• src/Langchain/Tool/WikipediaTool.hs +23/−11
• src/Langchain/Utils.hs +27/−0
• src/Langchain/VectorStore/Core.hs +50/−32
• src/Langchain/VectorStore/InMemory.hs +14/−9
• test/Spec.hs +4/−4
• test/Test/Langchain/Agent/Core.hs +0/−123
• test/Test/Langchain/Agent/ReAct.hs +210/−0
• test/Test/Langchain/DocumentLoader/Core.hs +11/−9
• test/Test/Langchain/DocumentLoader/DirectoryLoader.hs +41/−20
• test/Test/Langchain/Embeddings/Core.hs +7/−3
• test/Test/Langchain/LLM/Core.hs +34/−31
• test/Test/Langchain/LLM/Ollama.hs +75/−65
• test/Test/Langchain/Memory/Core.hs +52/−19
• test/Test/Langchain/Memory/TokenBufferMemory.hs +12/−14
• test/Test/Langchain/OutputParser/Core.hs +14/−12
• test/Test/Langchain/PromptTemplate.hs +7/−3
• test/Test/Langchain/Retriever/Core.hs +10/−5
• test/Test/Langchain/Runnable/Chains.hs +9/−6
• test/Test/Langchain/Runnable/ConversationChains.hs +17/−15
• test/Test/Langchain/Runnable/Core.hs +14/−11
• test/Test/Langchain/Runnable/Utils.hs +13/−7
• test/Test/Langchain/Tool/Core.hs +66/−73
• test/Test/Langchain/VectorStore/Core.hs +1/−1

@@ -8,6 +8,28 @@  ## Unreleased +## 0.0.3.0 - 2025-11-16++### Added++- Added Agent middleware support.+- Added image input support for OpenAI and Gemini.++### Fixed++- Fixed Ollama stream's onComplete callback.+- Fixed system_fingerprint field to be nullable.++### Changed++- * Revamped Agent module with native tool_call support and improved architecture.+- * Migrated to Mercury's OpenAI client.+- * Changed Ollama params to use ChatOps type.+- * Renamed ChatMessage to ChatHistory.+- * Parameterized StreamHandler Token type.+- * Added Langchain error type for better error handling.+- Updated ollama-haskell to 0.2.1.0.+ ## 0.0.2.0 - 2025-05-04  ### Added

@@ -24,6 +24,7 @@ - **Text Splitter**: Components for splitting text into smaller chunks for processing. - **Output Parser**: Components for parsing and processing the output of LLMs. - **VectorStore and Retriever**: Mechanism for storing and retrieving document embeddings.+   * Includes support for Faiss, a library for efficient similarity search. This integration is available through the separate [`faiss-hs`](https://github.com/tusharad/faiss-hs) repository. - **Embeddings**: Components for generating vector representations of text.  ## Current Supported Providers@@ -31,6 +32,7 @@   - Ollama   - OpenAI   - Huggingface+  - OpenAI compatible APIs (LMStudio, OpenRouter, Llama-cpp, Deepseek)   - More to come...  ## Installation@@ -74,6 +76,10 @@         Left err -> putStrLn $ "Error: " ++ err         Right response -> putStrLn $ "Translation: " ++ (T.unpack response) ```++## Projects using langchain-hs++- [ai-chatbot-hs](https://github.com/tusharad/ai-chatbot-hs)  ## Contributing 

@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.37.0.+-- This file has been generated from package.yaml by hpack version 0.38.1. -- -- see: https://github.com/sol/hpack  name:           langchain-hs-version:        0.0.2.0+version:        0.0.3.0 synopsis:       Haskell implementation of Langchain description:    Build LLM-powered applications in Haskell. category:       Web, AI@@ -34,8 +34,10 @@  library   exposed-modules:-      Langchain.Agents.Core-      Langchain.Agents.React+      Langchain.Agent.Core+      Langchain.Agent.Executor+      Langchain.Agent.Middleware+      Langchain.Agent.ReAct       Langchain.Callback       Langchain.Chain.RetrievalQA       Langchain.DocumentLoader.Core@@ -43,14 +45,18 @@       Langchain.DocumentLoader.FileLoader       Langchain.DocumentLoader.PdfLoader       Langchain.Embeddings.Core+      Langchain.Embeddings.Gemini       Langchain.Embeddings.Ollama       Langchain.Embeddings.OpenAI+      Langchain.Error       Langchain.LLM.Core+      Langchain.LLM.Deepseek+      Langchain.LLM.Gemini       Langchain.LLM.Huggingface       Langchain.LLM.Internal.Huggingface-      Langchain.LLM.Internal.OpenAI       Langchain.LLM.Ollama       Langchain.LLM.OpenAI+      Langchain.LLM.OpenAICompatible       Langchain.Memory.Core       Langchain.Memory.TokenBufferMemory       Langchain.OutputParser.Core@@ -64,9 +70,11 @@       Langchain.TextSplitter.Character       Langchain.Tool.Calculator       Langchain.Tool.Core+      Langchain.Tool.DuckDuckGo       Langchain.Tool.Utils       Langchain.Tool.WebScraper       Langchain.Tool.WikipediaTool+      Langchain.Utils       Langchain.VectorStore.Core       Langchain.VectorStore.InMemory   other-modules:@@ -78,6 +86,7 @@       aeson ==2.*     , async <3     , base >=4.7 && <5+    , base64-bytestring ==1.2.*     , bytestring >=0.10     , conduit >=1.2 && <1.4     , containers >=0.6 && <0.9@@ -85,11 +94,14 @@     , filepath <2     , http-conduit ==2.*     , http-types >=0.11 && <0.13-    , ollama-haskell+    , ollama-haskell >=0.2.1+    , openai >=2.2.1     , parsec <4     , pdf-toolbox-document ==0.1.4     , tagsoup <0.15     , text >=1.2 && <3+    , time >=1.9 && <1.15+    , transformers     , vector <0.14   default-language: Haskell2010 @@ -97,7 +109,7 @@   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:-      Test.Langchain.Agent.Core+      Test.Langchain.Agent.ReAct       Test.Langchain.DocumentLoader.Core       Test.Langchain.DocumentLoader.DirectoryLoader       Test.Langchain.Embeddings.Core@@ -123,6 +135,7 @@       aeson ==2.*     , async <3     , base >=4.7 && <5+    , base64-bytestring ==1.2.*     , bytestring >=0.10     , conduit >=1.2 && <1.4     , containers >=0.6 && <0.9@@ -131,7 +144,8 @@     , http-conduit ==2.*     , http-types >=0.11 && <0.13     , langchain-hs-    , ollama-haskell+    , ollama-haskell >=0.2.1+    , openai >=2.2.1     , parsec <4     , pdf-toolbox-document ==0.1.4     , tagsoup <0.15@@ -139,5 +153,7 @@     , tasty-hunit     , temporary     , text+    , time >=1.9 && <1.15+    , transformers     , vector <0.14   default-language: Haskell2010

@@ -0,0 +1,303 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{- |+Module      : Langchain.Agent.Core+Description : Core types and abstractions for LangChain agents+Copyright   : (c) 2025 Tushar Adhatrao+License     : MIT+Maintainer  : Tushar Adhatrao <tusharadhatrao@gmail.com>+Stability   : experimental++This module provides the foundational types and typeclasses for building agents+in langchain-hs. An LLM Agent runs tools in a loop to achieve a goal.+An agent runs until a stop condition is met -+when the model emits a final output or an iteration limit is reached.+-}+module Langchain.Agent.Core+  ( -- * Agent Typeclass+    Agent (..)++    -- * Agent Actions and Results+  , AgentAction (..)+  , AgentFinish (..)+  , AgentStep (..)+  , PlanResult (..)++    -- * Agent State and Configuration+  , AgentState (..)+  , AgentConfig (..)+  , AgentCallbacks (..)+  , defaultAgentConfig+  , defaultAgentCallbacks++    -- * Tool support+  , ToolAcceptingToolCall (..)++    -- * Memory support+  , SomeMemory (..)+  ) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Aeson+import Data.Map.Strict (Map)+import Data.Text (Text)+import Data.Time (UTCTime)+import GHC.Generics (Generic)+import Langchain.Error (LangchainResult)+import Langchain.LLM.Core (ToolCall)+import Langchain.Memory.Core (BaseMemory)+import Langchain.Tool.Core++-- | Represents an action (ToolCall) that an agent has decided to take.+data AgentAction = AgentAction+  { actionToolCall :: [ToolCall]+  -- ^ tool call+  , actionLog :: Text+  -- ^ LLM's response while suggesting the tool call+  , actionMetadata :: Map Text Text+  -- ^ Additional metadata about the action+  }+  deriving (Show, Eq)++-- | Represents the final result when an agent completes its task.+data AgentFinish = AgentFinish+  { agentOutput :: Text+  -- ^ The final answer or result+  , finishMetadata :: Map Text Text+  -- ^ Additional information about the execution+  , finishLog :: Text+  -- ^ Final thoughts or reasoning+  }+  deriving (Show, Eq, Generic, ToJSON, FromJSON)++-- | Represents one step in the agent's execution.+data AgentStep = AgentStep+  { stepAction :: AgentAction+  -- ^ The action that was executed+  , stepObservation :: Text+  -- ^ The result/observation from the executed tool call+  , stepTimestamp :: UTCTime+  -- ^ When this step occurred+  }+  deriving (Show, Eq)++{- |+A SomeMemory is a wrapper around any type that implements BaseMemory.++> data MyMemory = MyMemory { ... }+> instance BaseMemory MyMemory where ...+>+> let memory = MyMemory { ... }+> let someMemory = SomeMemory memory+>+> let msg = defaultMessage { role = System, content = "You are an AI assistant" }+> let someMemory2 = SomeMemory (WindowBufferMemory 5 (NE.fromList [msg]))+-}+data SomeMemory where+  SomeMemory ::+    (BaseMemory m) =>+    m ->+    SomeMemory++instance Show SomeMemory where+  show (SomeMemory _) = "SomeMemory { <memory instance> }"++{- | Current state of the agent during execution.++Tracks:+- Memory instance for managing chat history+- Current input being processed+- Number of iterations so far+-}+data AgentState = AgentState+  { agentMemory :: SomeMemory+  -- ^ Memory instance for managing chat history with the LLM+  , agentInput :: Text+  -- ^ Current user input/query+  , agentIterations :: Int+  -- ^ Number of iterations so far+  }++instance Show AgentState where+  show (AgentState mem inp iters) =+    "AgentState { agentMemory = "+      ++ show mem+      ++ ", agentInput = "+      ++ show inp+      ++ ", agentIterations = "+      ++ show iters+      ++ " }"++data AgentConfig = AgentConfig+  { maxIterations :: Int+  -- ^ Maximum number of agent steps (default: 15)+  , maxExecutionTime :: Maybe Int+  -- ^ Maximum execution time in seconds (Nothing = no limit)+  , verboseLogging :: Bool+  -- ^ Enable verbose logging (default: False)+  , stateMemory :: Maybe SomeMemory+  {- ^ Configure type of Chat memory you want use.+  ^ (default: windowBufferMessages with 100 window size)+  -}+  }+  deriving (Show)++{- | Callbacks for agent events.+Allows hooking into various points in the agent lifecycle.+-}+data AgentCallbacks = AgentCallbacks+  { onAgentStart :: Text -> IO ()+  -- ^ Called when agent starts with the input+  , onAgentAction :: AgentAction -> IO ()+  -- ^ Called before executing an action+  , onAgentObservation :: Text -> IO ()+  -- ^ Called after receiving an observation / result of the tool call+  , onAgentFinish :: AgentFinish -> IO ()+  -- ^ Called when agent completes+  , onAgentStep :: AgentStep -> IO ()+  -- ^ Called after each complete step+  }++{- |+A ToolAcceptingToolCall is a special type of tool that+can be used by an agent to execute a tool call.++It is a wrapper around a tool type whose input is a ToolCall and output is a Text.+It is user's responsibility wrap your existing tool into this type.++Example:++> data AgeFinderTool = AgeFinderTool+> instance Tool AgeFinderTool where+>   type Input AgeFinderTool = ToolCall+>   type Output AgeFinderTool = Text+>   toolName _ = "age_finder"+>   toolDescription _ = "Finds the age of a person given their name."+>   runTool _ (ToolCall _ _ ToolFunction {..}) = do+>     if toolFunctionName == "age_finder"+>       then do+>         case HM.lookup "name" toolFunctionArguments of+>           Nothing -> pure "Unknown"+>           Just (String name_) -> pure $ getAge name_+>           _ -> pure "Unknown"+>       else pure "Unknown"+>+>   getAge name_ = case name_ of+>     "Alice" -> "30"+>     "Bob" -> "25"+>     _ -> "Unknown"+-}+data ToolAcceptingToolCall where+  ToolAcceptingToolCall ::+    ( Tool t+    , Input t ~ ToolCall+    , Output t ~ Text+    ) =>+    t -> ToolAcceptingToolCall++instance Eq ToolAcceptingToolCall where+  (ToolAcceptingToolCall t1) == (ToolAcceptingToolCall t2) = toolName t1 == toolName t2++instance Show ToolAcceptingToolCall where+  show (ToolAcceptingToolCall t) =+    "ToolAcceptingToolCall { name = " ++ show (toolName t) ++ " }"++data PlanResult = Continue AgentAction | Done AgentFinish+  deriving (Eq, Show)++{- | Core Agent typeclass.++An agent is a system that can plan and execute actions to accomplish a task.+Different agent types (ReAct, Plan-and-Execute, etc.) implement this interface.+-}+class Agent a where+  {- | Plan the next action or finish.++  Given the current state, decide:+  - What tool call to make next (Left AgentAction), or+  - That the task is complete and return the final result (Right AgentFinish)+  -}+  plan ::+    a ->+    AgentState ->+    IO (LangchainResult PlanResult)++  -- | Get the tools available to this agent.+  getTools :: a -> [ToolAcceptingToolCall]++  -- | Execute a tool.+  executeTool :: a -> ToolCall -> IO (LangchainResult Text)++  {- | Prepare the agent for execution.+  Initialize any necessary state before starting.+  Default implementation does nothing.+  -}+  initialize :: a -> AgentState -> IO (LangchainResult AgentState)+  initialize _ state = pure $ Right state++  {- | Clean up after agent execution.+  Release resources, save state, etc.+  Default implementation does nothing.+  -}+  finalize :: a -> AgentState -> IO ()+  finalize _ _ = pure ()++  -- | MonadIO version of plan+  planM ::+    MonadIO m =>+    a ->+    AgentState ->+    m (LangchainResult PlanResult)+  planM agent state = liftIO $ plan agent state++  -- | MonadIO version of executeTool+  executeToolM :: MonadIO m => a -> ToolCall -> m (LangchainResult Text)+  executeToolM a i = liftIO $ executeTool a i++  -- | MonadIO version of initialize+  initializeM ::+    MonadIO m =>+    a ->+    AgentState ->+    m (LangchainResult AgentState)+  initializeM agent state = liftIO $ initialize agent state++  -- | MonadIO version of finalize+  finalizeM :: MonadIO m => a -> AgentState -> m ()+  finalizeM agent state = liftIO $ finalize agent state++{- | Default agent configuration.++Sensible defaults:+- 15 max iterations+- No time limit+- No verbose logging+- WindowBufferMemory with window size 100+-}+defaultAgentConfig :: AgentConfig+defaultAgentConfig =+  AgentConfig+    { maxIterations = 15+    , maxExecutionTime = Nothing+    , verboseLogging = False+    , stateMemory = Nothing+    }++{- | Default agent callbacks (all no-ops).+Useful as a starting point for custom callbacks.+-}+defaultAgentCallbacks :: AgentCallbacks+defaultAgentCallbacks =+  AgentCallbacks+    { onAgentStart = \_ -> pure ()+    , onAgentAction = \_ -> pure ()+    , onAgentObservation = \_ -> pure ()+    , onAgentFinish = \_ -> pure ()+    , onAgentStep = \_ -> pure ()+    }

@@ -0,0 +1,261 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++{- |+Module      : Langchain.Agent.Executor+Description : Agent execution loop and orchestration+Copyright   : (c) 2025 Tushar Adhatrao+License     : MIT+Maintainer  : Tushar Adhatrao <tusharadhatrao@gmail.com>+Stability   : experimental++This module provides the execution engine for agents. It orchestrates the+agent planning loop, tool execution, and result collection.++The executor handles:+- The main agent loop (plan -> execute -> observe)+- Error handling and recovery+- Iteration limits and timeouts+- Callbacks and logging+- State management+-}+module Langchain.Agent.Executor+  ( -- * Main Execution Functions+    runAgentExecutor++    -- * Result Types+  , AgentExecutionResult (..)+  , ExecutionMetrics (..)++    -- * Utilities+  , createInitialState+  )+where++import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Trans.Except+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time (UTCTime, diffUTCTime, getCurrentTime)+import Langchain.Agent.Core+import Langchain.Agent.Middleware+import Langchain.Error+  ( LangchainResult+  , agentError+  )+import Langchain.LLM.Core+import Langchain.Memory.Core++data AgentExecutionResult = AgentExecutionResult+  { executionFinish :: AgentFinish+  -- ^ The final result of the agent execution+  , executionSteps :: [AgentStep]+  -- ^ All tool calls made and their results+  , executionMetrics :: ExecutionMetrics+  -- ^ Performance metrics+  }+  deriving (Show, Eq)++data ExecutionMetrics = ExecutionMetrics+  { metricsIterations :: Int+  -- ^ Number of agent iterations+  , metricsExecutionTime :: Double+  -- ^ Total time in seconds+  , metricsToolCalls :: Int+  -- ^ Number of tool calls made+  , metricsSuccess :: Bool+  -- ^ Whether execution completed successfully+  }+  deriving (Show, Eq)++-- | Create the initial state of the agent with default memory.+createInitialState :: Maybe SomeMemory -> Text -> AgentState+createInitialState mbSomeMemory input =+  AgentState+    { agentMemory = fromMaybe (SomeMemory defaultMemory) mbSomeMemory+    , agentInput = input+    , agentIterations = 0+    }+  where+    defaultMemory =+      WindowBufferMemory+        { maxWindowSize = 100+        , windowBufferMessages = initialChatMessage "You are a helpful AI assistant."+        }++{-+Returns False if:+- Max iterations reached+- Max execution time exceeded+-}+shouldContinue :: AgentConfig -> AgentState -> Double -> Bool+shouldContinue AgentConfig {..} state elapsedSeconds =+  iterationsOk && timeOk+  where+    iterationsOk = agentIterations state < maxIterations+    timeOk = case maxExecutionTime of+      Nothing -> True+      Just maxTime -> elapsedSeconds < fromIntegral maxTime++-- | Helper function to add an action to the state's memory+addActionToState :: AgentState -> AgentAction -> IO (LangchainResult AgentState)+addActionToState state action =+  case agentMemory state of+    SomeMemory mem -> do+      eMemWithAction <- addMessage mem (actionToMsg action)+      case eMemWithAction of+        Left err -> pure $ Left err+        Right memWithAction -> pure $ Right $ state {agentMemory = SomeMemory memWithAction}+  where+    actionToMsg act =+      defaultMessage+        { role = Assistant+        , content = actionLog act+        , messageData =+            defaultMessageData+              { toolCalls = Just (actionToolCall act)+              }+        }++-- | Helper function to add observations to the state's memory+addObservationsToState :: AgentState -> [Text] -> IO (LangchainResult AgentState)+addObservationsToState state observations =+  case agentMemory state of+    SomeMemory mem -> do+      eMemsWithObs <- sequenceA <$> traverse (addMessage mem . toolResultToMsg) observations+      case eMemsWithObs of+        Left err -> pure $ Left err+        Right mems -> pure $ Right $ state {agentMemory = SomeMemory (last mems)}+  where+    toolResultToMsg res =+      defaultMessage+        { role = Tool+        , content = res+        }++executeAgentLoop ::+  Agent a =>+  a ->+  AgentConfig ->+  AgentCallbacks ->+  [AgentMiddleware a] ->+  AgentState ->+  UTCTime ->+  IO (LangchainResult AgentExecutionResult)+executeAgentLoop agent config callbacks middlewares initialState startTime =+  loop agent initialState []+  where+    loop agent0 state0 steps = runExceptT $ do+      currentTime <- liftIO getCurrentTime+      let elapsedSeconds = realToFrac $ diffUTCTime currentTime startTime+      -- Check termination conditions+      if not (shouldContinue config state0 elapsedSeconds)+        then do+          let err = agentError "Agent execution exceeded limits" Nothing Nothing+          ExceptT . pure $ Left err+        else do+          -- Plan next action+          when (verboseLogging config) $+            liftIO $+              putStrLn $+                "[Agent] Planning iteration " <> show (agentIterations state0)+          (state1, agent1) <-+            ExceptT $+              applyMiddlewares beforeModelCall middlewares (state0, agent0)+          plan_ <- ExceptT $ plan agent1 state1+          (state2, agent2) <-+            ExceptT $+              applyMiddlewares afterModelCall middlewares (state1, agent1)+          case plan_ of+            (Done finish) -> do+              -- Agent has finished+              let metrics =+                    ExecutionMetrics+                      { metricsIterations = agentIterations state2+                      , metricsExecutionTime = elapsedSeconds+                      , metricsToolCalls = length steps+                      , metricsSuccess = True+                      }+              return $ AgentExecutionResult finish steps metrics+            (Continue action) -> do+              -- add toolCalls in state memory+              state3 <- ExceptT $ addActionToState state2 action+              -- Execute action+              liftIO $ onAgentAction callbacks action+              (state4, agent4) <-+                ExceptT $+                  applyMiddlewares beforeToolCall middlewares (state3, agent2)+              when (verboseLogging config) $+                liftIO $+                  putStrLn $+                    "[Agent] Executing: " <> show (actionToolCall action)+              observations <-+                ExceptT $+                  sequenceA <$> traverse (executeTool agent4) (actionToolCall action)+              mapM_ (liftIO . onAgentObservation callbacks) observations+              when (verboseLogging config) $+                liftIO $+                  putStrLn $+                    "[Agent] Observation: " <> mconcat (T.unpack <$> observations)+              -- Record step+              timestamp <- liftIO getCurrentTime+              let newSteps = map (\obs -> AgentStep action obs timestamp) observations+              mapM_ (liftIO . onAgentStep callbacks) newSteps+              -- Update state memory with tool results and continue+              state5 <-+                ExceptT $+                  addObservationsToState state4 observations+              (state6, agent6) <-+                ExceptT $+                  applyMiddlewares afterToolCall middlewares (state5, agent4)+              let newState =+                    state6+                      { agentIterations = agentIterations state6 + 1+                      }+              ExceptT (loop agent6 newState (steps ++ newSteps))++{- |+ Runs the agent executor.++ This function initializes the agent, runs the agent loop, and returns the final result.++ Arguments:+ - agent: The agent to run+ - config: The agent configuration+ - callbacks: The agent callbacks+ - input: The input to the agent++ Returns:+ - The final result of the agent execution+ - The execution metrics+ - The execution steps+-}+runAgentExecutor ::+  Agent a =>+  a ->+  AgentConfig ->+  AgentCallbacks ->+  [AgentMiddleware a] ->+  Text ->+  IO (LangchainResult AgentExecutionResult)+runAgentExecutor agent0 config callbacks middlewares input = do+  startTime <- getCurrentTime+  onAgentStart callbacks input+  runExceptT $ do+    let initialState = createInitialState (stateMemory config) input+    state0 <- ExceptT $ initialize agent0 initialState+    (state1, agent1) <-+      ExceptT $+        applyMiddlewares beforeAgent middlewares (state0, agent0)+    result <-+      ExceptT $+        executeAgentLoop agent1 config callbacks middlewares state1 startTime+    (state2, agent2) <-+      ExceptT $+        applyMiddlewares afterAgent middlewares (state1, agent1)+    liftIO $ finalize agent2 state2+    liftIO $ onAgentFinish callbacks (executionFinish result)+    return result

@@ -0,0 +1,133 @@+{-# LANGUAGE RankNTypes #-}++{- |+Module      : Langchain.Agent.Middleware+Description : Built-in middlewares for LangChain agents+Copyright   : (c) 2025 Tushar Adhatrao+License     : MIT+Maintainer  : Tushar Adhatrao <tusharadhatrao@gmail.com>+Stability   : experimental++This module provides a comprehensive set of built-in middlewares for agents,+similar to Python LangChain's middleware system. Middlewares allow you to hook+into various points in the agent execution lifecycle.++Available middlewares:+- defaultMiddleware: No-op middleware (base implementation)+- humanInLoopMiddleware: Pause for human approval before tool execution+- toolCallLimitMiddleware: Limit the number of tool calls+-}+module Langchain.Agent.Middleware+  ( -- * Middleware Type+    AgentMiddleware (..)+  , applyMiddlewares++    -- * Built-in Middlewares+  , defaultMiddleware+  , humanInLoopMiddleware+  , toolCallLimitMiddleware+  ) where++import Control.Monad (foldM)+import Data.IORef (modifyIORef', newIORef, readIORef)+import qualified Data.List.NonEmpty as NE+import qualified Data.Text as T+import Langchain.Agent.Core+import Langchain.Error+  ( LangchainResult+  , agentError+  , fromString+  )+import Langchain.LLM.Core (Message (messageData), MessageData (toolCalls))+import Langchain.Memory.Core (BaseMemory (messages))++-- | Middleware hooks around agent execution steps.+data Agent a => AgentMiddleware a = AgentMiddleware+  { beforeModelCall :: (AgentState, a) -> IO (LangchainResult (AgentState, a))+  , afterModelCall :: (AgentState, a) -> IO (LangchainResult (AgentState, a))+  , beforeToolCall :: (AgentState, a) -> IO (LangchainResult (AgentState, a))+  , afterToolCall :: (AgentState, a) -> IO (LangchainResult (AgentState, a))+  , beforeAgent :: (AgentState, a) -> IO (LangchainResult (AgentState, a))+  , afterAgent :: (AgentState, a) -> IO (LangchainResult (AgentState, a))+  }++-- | Default middleware that does nothing (no-op).+defaultMiddleware :: Agent a => AgentMiddleware a+defaultMiddleware =+  AgentMiddleware+    { beforeModelCall = pure . Right+    , afterModelCall = pure . Right+    , beforeToolCall = pure . Right+    , afterToolCall = pure . Right+    , beforeAgent = pure . Right+    , afterAgent = pure . Right+    }++-- | Sequentially apply a list of middlewares for a given phase.+applyMiddlewares ::+  (AgentMiddleware a -> (AgentState, a) -> IO (LangchainResult (AgentState, a))) ->+  [AgentMiddleware a] ->+  (AgentState, a) ->+  IO (LangchainResult (AgentState, a))+applyMiddlewares f mws st =+  foldM+    ( \acc mw -> case acc of+        Left err -> pure $ Left err+        Right s -> f mw s+    )+    (Right st)+    mws++{- | Human-in-the-loop middleware.+Pauses execution before each tool call and asks for human approval.+This is useful for sensitive operations or debugging.++Example:+> runAgentExecutor agent config callbacks [humanInLoopMiddleware] "input"+-}+humanInLoopMiddleware :: Agent a => AgentMiddleware a+humanInLoopMiddleware =+  defaultMiddleware+    { beforeToolCall = \(st, a) -> do+        case agentMemory st of+          SomeMemory mem -> do+            eRes <- messages mem+            case eRes of+              Left err -> pure $ Left err+              Right msgs -> do+                let msg = NE.last msgs+                    toolCallLst = toolCalls $ messageData msg+                putStrLn $ "Approve this tool call? " ++ show toolCallLst+                putStrLn "(y/n): "+                resp <- getLine+                if resp == "y"+                  then pure $ Right (st, a)+                  else pure $ Left $ fromString "Tool call rejected by human"+    }++{- | Tool call limit middleware.+Limits the total number of tool calls during agent execution.+This helps prevent excessive tool usage and control costs.++Example:+> toolCallLimitMiddleware 20  -- Limit to 20 tool calls+-}+toolCallLimitMiddleware :: Agent a => Int -> IO (AgentMiddleware a)+toolCallLimitMiddleware maxCalls = do+  counter <- newIORef 0+  pure $+    defaultMiddleware+      { beforeToolCall = \(st, a) -> do+          count <- readIORef counter+          if count >= maxCalls+            then+              pure $+                Left $+                  agentError+                    (T.pack $ "Tool call limit exceeded: " <> show maxCalls)+                    Nothing+                    (Just (T.pack "toolCallLimitMiddleware"))+            else do+              modifyIORef' counter (+ 1)+              pure $ Right (st, a)+      }

@@ -0,0 +1,169 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}++{- |+Module      : Langchain.Agent.ReAct+Description : ReAct (Reasoning + Acting) agent implementation+Copyright   : (c) 2025 Tushar Adhatrao+License     : MIT+Maintainer  : Tushar Adhatrao <tusharadhatrao@gmail.com>+Stability   : experimental++This module implements the ReAct (Reasoning + Acting) agent pattern.+ReAct combines reasoning traces and task-specific actions in an interleaved manner.+-}+module Langchain.Agent.ReAct+  ( -- * Agent Creation+    ReActAgent (..)+  , createReActAgent+  , createReActAgentWithPrompt++    -- * Prompt Templates+  , reActSystemPrompt+  ) where++import Control.Monad.Trans.Except+import Data.List (find)+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as T+import Langchain.Agent.Core+import qualified Langchain.Error as Error+import Langchain.LLM.Core+import Langchain.Memory.Core (BaseMemory (..))+import Langchain.Tool.Core++{- | ReAct agent.++Arguments:+- llm: The language model+- llmParams: The language model parameters+- systemPrompt: The system prompt+- maxThinkingSteps: The maximum number of thinking steps before forcing action+- tools: The tools available to the agent.+-}+data ReActAgent llm = ReActAgent+  { reactLLM :: llm+  -- ^ The language model for reasoning+  , reactLLMParams :: Maybe (LLMParams llm)+  -- ^ the llm params for language model+  , reactSystemPrompt :: Text+  -- ^ System prompt template+  , reactMaxThinkingSteps :: Int+  -- ^ Maximum consecutive thinking steps before forcing action (default: 3)+  , reactTools :: [ToolAcceptingToolCall]+  }++{- | Create a ReAct agent.++Arguments:+- llm: The language model+- llmParams: The language model parameters+- tools: The tools available to the agent++Important:+- It is user's responsibility to wrap the tools into ToolAcceptingToolCall.+- It is user's responsibility to pass tool_calls as part of LLMParams.+- The tool_calls shall be same as the reactTools (ToolAcceptingToolCall) list.+-}+createReActAgent ::+  -- | The language model+  llm ->+  -- | The language model parameters+  Maybe (LLMParams llm) ->+  -- | The tools available to the agent+  [ToolAcceptingToolCall] ->+  -- | The ReAct agent+  ReActAgent llm+createReActAgent llm mbLlmParams tools =+  ReActAgent+    { reactLLM = llm+    , reactLLMParams = mbLlmParams+    , reactSystemPrompt = reActSystemPrompt+    , reactMaxThinkingSteps = 3+    , reactTools = tools+    }++-- | Create a ReAct agent with a custom system prompt.+createReActAgentWithPrompt ::+  -- | The language model+  llm ->+  -- | The language model parameters+  Maybe (LLMParams llm) ->+  -- | The tools available to the agent+  [ToolAcceptingToolCall] ->+  -- | The custom system prompt+  Text ->+  -- | The ReAct agent+  ReActAgent llm+createReActAgentWithPrompt llm mbLlmParams tools prompt =+  ReActAgent+    { reactLLM = llm+    , reactLLMParams = mbLlmParams+    , reactSystemPrompt = prompt+    , reactMaxThinkingSteps = 3+    , reactTools = tools+    }++-- | Default system prompt for the ReAct agent.+reActSystemPrompt :: Text+reActSystemPrompt =+  "You are a helpful AI assistant that uses tools to answer user questions."++instance LLM llm => Agent (ReActAgent llm) where+  plan agent state = do+    let llm = reactLLM agent+        mbParams = reactLLMParams agent+    -- Get messages from memory - use case to handle existential type+    case agentMemory state of+      SomeMemory mem -> runExceptT $ do+        msgs <- ExceptT $ messages mem+        respMsg <- ExceptT $ chat llm msgs mbParams+        case toolCalls (messageData respMsg) of+          Nothing -> do+            -- No tool calls requested. Assume content as the final result+            pure $+              Done $+                AgentFinish+                  { agentOutput = content respMsg+                  , finishMetadata = Map.empty -- TODO: Add stuff from state+                  , finishLog = content respMsg+                  }+          Just toolCallList -> do+            pure $+              Continue+                AgentAction+                  { actionToolCall = toolCallList+                  , actionLog = content respMsg+                  , actionMetadata = Map.empty -- TODO: what to add here?+                  }++  getTools = reactTools++  executeTool agent toolCall = do+    let tools = getTools agent+    let inputFunctionName = toolFunctionName (toolCallFunction toolCall)+    case find (\(ToolAcceptingToolCall t) -> toolName t == inputFunctionName) tools of+      Nothing ->+        pure $+          Left $+            Error.fromString $+              "Cannot find tool with name: "+                <> T.unpack inputFunctionName+      Just (ToolAcceptingToolCall selectedTool) -> Right <$> runTool selectedTool toolCall++  initialize agent state = do+    let sysPrompt = reactSystemPrompt agent+        userInput = agentInput state+        sysMsg = defaultMessage {role = System, content = sysPrompt}+        userMsg = defaultMessage {role = User, content = userInput}+    case agentMemory state of+      SomeMemory mem -> runExceptT $ do+        memWithSys <- ExceptT $ addMessage mem sysMsg+        memWithUser <- ExceptT $ addMessage memWithSys userMsg+        pure+          AgentState+            { agentMemory = SomeMemory memWithUser+            , agentInput = userInput+            , agentIterations = 0+            }

@@ -1,154 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RecordWildCards #-}--{- |-Module      : Langchain.Agents.Core-Description : Core implementation of LangChain agents-Copyright   : (c) 2025 Tushar Adhatrao-License     : MIT-Maintainer  : Tushar Adhatrao <tusharadhatrao@gmail.com>--Agents use LLMs as reasoning engines to determine actions dynamically. --}-module Langchain.Agents.Core-  ( AgentAction (..)-  , AgentFinish (..)-  , AgentStep (..)-  , Agent (..)-  , AnyTool (..)-  , AgentState (..)-  , runAgent-  , runAgentLoop-  , executeTool-  , runSingleStep-  , customAnyTool-  ) where--import Control.Exception (SomeException, try)-import Data.List (find)-import qualified Data.Map.Strict as Map-import Data.Text (Text)-import qualified Data.Text as T-import Langchain.LLM.Core (Message (Message), Role (..), defaultMessageData)-import Langchain.Memory.Core (BaseMemory (..))-import Langchain.PromptTemplate (PromptTemplate)-import Langchain.Tool.Core (Tool (..))--{- |-Represents an action to be taken by the agent--}-data AgentAction = AgentAction-  { actionToolName :: Text-  -- ^ Tool name-  , actionInput :: Text-  -- ^ Input-  , actionLog :: Text-  -- ^ Execution log-  }-  deriving (Eq, Show)---- | Represents that agent has finished work with final value-data AgentFinish = AgentFinish-  { returnValues :: Map.Map Text Text -  , finishLog :: Text-  }-  deriving (Show, Eq)---- | Type that will be return from LLM --- Could be either Continue, making another call to LLM or Finish with final value-data AgentStep-  = Continue AgentAction-  | Finish AgentFinish-  deriving (Eq, Show)---- | Type for maintaining state of the agent -data (BaseMemory m) => AgentState m = AgentState-  { agentMemory :: m -- ^ Memory for storing chat history-  , agentToolResults :: [(Text, Text)] -- ^ Tool results-  , agentSteps :: [AgentAction] -- ^ Agent steps happened so far-  }-  deriving (Eq, Show)---- | 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-  }---- | 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]---- | 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-  case memWithInput of-    Left err -> return $ Left err-    Right updatedMem ->-      let newState = initialState {agentMemory = updatedMem}-       in runAgentLoop agent newState 0 10---- | Helper function for runAgent-runAgentLoop ::-  (Agent a, BaseMemory m) => a -> AgentState m -> Int -> Int -> IO (Either String AgentFinish)-runAgentLoop agent agentState@AgentState {..} currIter maxIter-  | currIter > maxIter = return $ Left "Max iterations excedded"-  | otherwise = do-      eStepResult <- runSingleStep agent agentState-      case eStepResult of-        Left err -> return $ Left err-        Right (Finish agentFinish) -> return $ Right agentFinish-        Right (Continue act@AgentAction {..}) -> do-          toolList <- agentTools agent-          toolResult <- executeTool toolList actionToolName actionInput-          case toolResult of-            Left err -> return $ Left err-            Right result -> do-              -- Add the tool result to memory as a tool message-              let toolMsg = Message Tool result defaultMessageData-              updatedMemResult <- addMessage agentMemory toolMsg-              case updatedMemResult of-                Left err -> return $ Left err-                Right updatedMem ->-                  let updatedState =-                        agentState-                          { agentMemory = updatedMem-                          , agentToolResults = agentToolResults ++ [(actionToolName, result)]-                          , agentSteps = agentSteps ++ [act]-                          }-                   in runAgentLoop agent updatedState (currIter + 1) maxIter---- | Alias for planNextAction-runSingleStep :: (Agent a, BaseMemory m) => a -> AgentState m -> IO (Either String AgentStep)-runSingleStep = planNextAction--{- |-Execute a single tool call-Handles tool lookup and input/output conversion.--}-executeTool :: [AnyTool] -> Text -> Text -> IO (Either String Text)-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-      resultE <- try $ do-        let typedInput = textToInput input-        result <- runTool anyTool typedInput-        return $ outputToText result-      case resultE of-        Left ex -> return $ Left $ "Tool execution error: " <> show (ex :: SomeException)-        Right output -> return $ Right output--{- |-Helper for creating custom tool wrappers-Requires conversion functions between Text and tool-specific types.--}-customAnyTool :: Tool a => a -> (Text -> Input a) -> (Output a -> Text) -> AnyTool-customAnyTool tool inputConv outputConv = AnyTool tool inputConv outputConv

@@ -1,162 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--{- |-Module      : Langchain.Agents.React-Description : Implementation of ReAct logic-Copyright   : (c) 2025 Tushar Adhatrao-License     : MIT-Maintainer  : Tushar Adhatrao <tusharadhatrao@gmail.com>--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-  ( defaultReactPromptTemplate-  , runReactAgent-  , ReactAgent (..)-  ) where--import qualified Data.Map.Strict as Map-import Data.Text (Text)-import qualified Data.Text as T-import Langchain.Agents.Core-import Langchain.LLM.Core-import Langchain.Memory.Core-import Langchain.OutputParser.Core-import Langchain.PromptTemplate-import Langchain.Tool.Core---- | 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"-      ]--newtype ReactAgentOutputParser = ReactAgentOutputParser AgentStep--instance OutputParser ReactAgentOutputParser where-  parse = parseReactOutput---- | Parses the output from a React agent-parseReactOutput :: Text -> Either String ReactAgentOutputParser-parseReactOutput text-  | T.isInfixOf "Final Answer:" text =-      -- Extract the final answer-      let answer = extractAfter "Final Answer:" text-       in Right $-            ReactAgentOutputParser $-              Finish $-                AgentFinish-                  { returnValues = Map.singleton "output" answer-                  , finishLog = text-                  }-  | T.isInfixOf "Action:" text && T.isInfixOf "Action Input:" text =-      -- Extract action and action input-      let actionName =-            extractAfter "Action:" $-              T.takeWhile (/= '\n') $-                T.dropWhile (/= 'A') text-          actionInput_ =-            extractAfter "Action Input:" $-              T.takeWhile (/= '\n') $-                snd $-                  T.breakOn "Action Input:" text-       in Right $-            ReactAgentOutputParser $-              Continue $-                AgentAction-                  { actionToolName = T.strip actionName-                  , actionInput = T.strip actionInput_-                  , actionLog = text-                  }-  | otherwise = Left $ "Could not parse agent output: " <> T.unpack text---- 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.drop 2 $ T.dropWhile (/= ':') afterMarker---- | ReactAgent Type-data (LLM llm) => ReactAgent llm = ReactAgent-  { reactLLM :: llm-  , reactLLMParams :: Maybe (LLMParams llm)-  , reactToolList :: [AnyTool]-  }---- | Run React Agent-runReactAgent ::-  LLM llm =>-  llm ->-  Maybe (LLMParams llm) ->-  [AnyTool] ->-  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--formatTools :: [AnyTool] -> Text-formatTools tools = T.intercalate "\n\n" $ map formatTool tools-  where-    formatTool (AnyTool tool _ _) =-      T.concat ["Tool: ", toolName tool, "\nDescription: ", toolDescription tool]--formatToolNames :: [AnyTool] -> Text-formatToolNames tools = T.intercalate ", " $ map (\(AnyTool tool _ _) -> toolName tool) tools--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--  agentPrompt _ = pure $ PromptTemplate ""-  agentTools ReactAgent {..} = pure reactToolList

@@ -83,5 +83,5 @@ stdOutCallback :: Callback stdOutCallback event = case event of   LLMStart -> putStrLn "Model operation started"-  LLMEnd -> putStrLn $ "Model completed with"+  LLMEnd -> putStrLn "Model completed with"   LLMError err -> putStrLn $ "Error occurred: " ++ err

@@ -20,6 +20,7 @@ import Data.Map.Strict (fromList) import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Lazy as TL import Langchain.DocumentLoader.Core (Document (..)) import Langchain.LLM.Core import Langchain.PromptTemplate (PromptTemplate (..), renderPrompt)@@ -47,7 +48,7 @@ -- | 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+  type RunnableOutput (RetrievalQA llm retriever) = Message    invoke RetrievalQA {..} question = do     -- Retrieve relevant documents@@ -55,7 +56,7 @@     case docResult of       Left err -> return $ Left err       Right docs -> do-        let context = T.intercalate "\n\n" $ map (\(Document c _) -> c) docs+        let context = T.intercalate "\n\n" $ map (\(Document c _) -> TL.toStrict c) docs         let vars = [("context", context)]          -- Render prompt with context and question

@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} {- | Module      : Langchain.DocumentLoader.Core Description : Core document loading functionality for LangChain Haskell@@ -50,9 +49,11 @@   , BaseLoader (..)   ) where +import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Aeson import Data.Map (Map, empty)-import Data.Text (Text)+import Data.Text.Lazy (Text)+import Langchain.Error (LangchainResult)  {- | Document container with content and metadata. Used for storing loaded data and associated metadata like source URLs or page numbers.@@ -110,12 +111,18 @@     return $ Right (splitText defaultCharacterSplitterOps content) @ -}-class BaseLoader m where+class BaseLoader loader where   -- | Load all documents from the source.-  load :: m -> IO (Either String [Document])+  load :: loader -> IO (LangchainResult [Document]) +  loadM :: MonadIO m => loader -> m (LangchainResult [Document])+  loadM loader = liftIO $ load loader+   -- | Load all the document and split them using recursiveCharacterSpliter-  loadAndSplit :: m -> IO (Either String [Text])+  loadAndSplit :: loader -> IO (LangchainResult [Text])++  loadAndSplitM :: MonadIO m => loader -> m (LangchainResult [Text])+  loadAndSplitM loader = liftIO $ loadAndSplit loader  {- $examples Key test case demonstrations:

@@ -12,10 +12,10 @@ DirectoryLoader document loader implements functionality for reading files from disk into Documents -} module Langchain.DocumentLoader.DirectoryLoader-  ( -    -- * Directory loader+  ( -- * Directory loader     DirectoryLoader (..)   , DirectoryLoaderOptions (..)+     -- * Default functions   , defaultDirectoryLoaderOptions   ) where@@ -23,12 +23,14 @@ import Control.Concurrent.Async (mapConcurrently) import Control.Monad (filterM) import Data.Maybe (listToMaybe)+import qualified Data.Text as T import Langchain.DocumentLoader.Core import Langchain.DocumentLoader.FileLoader (FileLoader (FileLoader)) import Langchain.DocumentLoader.PdfLoader (PdfLoader (PdfLoader))+import Langchain.Error (LangchainError, llmError) import Langchain.TextSplitter.Character import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)-import System.FilePath (takeFileName, takeExtension, (</>))+import System.FilePath (takeExtension, takeFileName, (</>))  -- | Options for directory loading behavior data DirectoryLoaderOptions = DirectoryLoaderOptions@@ -71,7 +73,7 @@ shouldIncludeFile opts path =   let ext = takeExtension path       fName = takeFileName path-      isHidden = if listToMaybe fName == Just '.' then True else False+      isHidden = listToMaybe fName == Just '.'       matchesExt = null (extensions opts) || ext `elem` extensions opts       passesHiddenCheck = not (excludeHidden opts) || not isHidden    in matchesExt && passesHiddenCheck@@ -99,22 +101,33 @@         -- Skip hidden directories if excludeHidden is set         let visibleSubdirs =               if excludeHidden opts-                then filter (\d -> not (null d) && last d /= '.') subdirs+                then filter (\d -> not (null d) && listToMaybe d /= Just '.') subdirs                 else subdirs          -- Process subdirectories (potentially in parallel)         if useMultithreading opts && not (null visibleSubdirs)-          then concat <$> mapConcurrently (getFilesInDirectory opts (currentDepth + 1)) 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 :: FilePath -> IO (Either LangchainError [Document]) loadFileToDocument path = do   exists <- doesFileExist path   if not exists-    then return $ Left $ "File does not exist: " ++ path+    then+      return $+        Left+          ( llmError+              (T.pack $ "File does not exist: " ++ path)+              Nothing+              Nothing+          )     else do       -- if file is pdf then read it using PdfLoader else use fileLoader       if takeExtension path == ".pdf"@@ -138,11 +151,13 @@         let (errors, documents) = foldr separateResults ([], []) docs          -- Return documents or combined error message-        case errors of-          [] -> return $ Right documents-          _ -> return $ Left $ unlines errors+        case listToMaybe errors of+          Nothing -> return $ Right documents+          Just err -> return $ Left err       else-        return $ Left $ "Directory does not exist: " ++ dirPath+        return $+          Left $+            llmError (T.pack $ "Directory does not exist: " ++ dirPath) Nothing Nothing     where       separateResults (Left err) (errs, docs) = (err : errs, docs)       separateResults (Right doc) (errs, docs) = (errs, doc <> docs)

@@ -30,8 +30,10 @@  import Data.Aeson import Data.Map (fromList)-import Data.Text (pack)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL import Langchain.DocumentLoader.Core+import Langchain.Error (SomeException, llmError, try) import Langchain.TextSplitter.Character import System.Directory (doesFileExist) @@ -43,13 +45,13 @@ >>> FileLoader "docs/example.txt" FileLoader "docs/example.txt" -}-data FileLoader = FileLoader FilePath+newtype FileLoader = FileLoader FilePath  instance BaseLoader FileLoader where   -- \| Load document with file source metadata   --   --  Example:-  +   --  >>> load (FileLoader "test.txt")   --  Right [Document {pageContent = "Test content", metadata = fromList [("source", "test.txt")]}]   --@@ -57,16 +59,31 @@     exists <- doesFileExist path     if exists       then do-        content <- readFile path-        let meta = fromList [("source", String $ pack path)]-        return $ Right [Document (pack content) meta]+        eContent <- try $ readFile path+        case eContent of+          Left err ->+            return $+              Left $+                llmError+                  (T.pack $ "Error reading file: " ++ path ++ show (err :: SomeException))+                  Nothing+                  Nothing+          Right content -> do+            let meta = fromList [("source", String $ T.pack path)]+            return $ Right [Document (TL.pack content) meta]       else-        return $ Left $ "File not found: " ++ path+        return $+          Left+            ( llmError+                (T.pack $ "File not found: " ++ path)+                Nothing+                Nothing+            )    -- \| Load and split content using default character splitter   --   --  Example:-  +   --  >>> loadAndSplit (FileLoader "split.txt")   --  Right ["Paragraph 1", "Paragraph 2", ...]   --@@ -74,10 +91,24 @@     exists <- doesFileExist path     if exists       then do-        content <- readFile path-        return $ Right $ splitText defaultCharacterSplitterOps (pack content)+        eContent <- try $ readFile path+        case eContent of+          Left err ->+            return $+              Left $+                llmError+                  (T.pack $ "Error reading file: " ++ path ++ show (err :: SomeException))+                  Nothing+                  Nothing+          Right content -> return $ Right $ splitText defaultCharacterSplitterOps (TL.pack content)       else-        return $ Left $ "File not found: " ++ path+        return $+          Left+            ( llmError+                (T.pack $ "File not found: " ++ path)+                Nothing+                Nothing+            )  {- $examples Test case patterns:

@@ -8,7 +8,7 @@ Maintainer  : Tushar Adhatrao <tusharadhatrao@gmail.com> Stability   : experimental -This module provides a loader for loading PDF files. +This module provides a loader for loading PDF files. -} module Langchain.DocumentLoader.PdfLoader   ( PdfLoader (..)@@ -16,8 +16,11 @@  import Data.Aeson import Data.Map (fromList)+import qualified Data.Text.Lazy as TL import Langchain.DocumentLoader.Core+import Langchain.Error (llmError) import Langchain.TextSplitter.Character+import Langchain.Utils (showText) import Pdf.Document hiding (Document) import System.Directory (doesFileExist) @@ -44,16 +47,25 @@     catalog <- documentCatalog doc     rootNode <- catalogPageNode catalog     count <- pageNodeNKids rootNode-    textList <- sequence [pageExtractText =<< pageNodePageByNum rootNode i | i <- [0 .. count - 1]]-    pure-      $ map-        ( \(content, pageNum) ->+    textList <-+      sequence+        [ pageExtractText+            =<< pageNodePageByNum rootNode i+        | i <- [0 .. count - 1]+        ]+    pure $+      zipWith+        ( \content pageNum ->             Document               { pageContent = content-              , metadata = fromList [("page number", Number $ fromIntegral pageNum)]+              , metadata =+                  fromList+                    [ ("page number", Number $ fromIntegral pageNum)+                    ]               }         )-      $ zip textList [1 .. count]+        (map TL.fromStrict textList)+        [1 .. count]  {- | A loader for PDF files.@@ -62,7 +74,7 @@ It implements the 'BaseLoader' interface to provide methods for loading and splitting PDF content. -}-data PdfLoader = PdfLoader FilePath+newtype PdfLoader = PdfLoader FilePath  instance BaseLoader PdfLoader where   -- \|@@ -82,7 +94,9 @@         content <- readPdf path         return $ Right content       else-        return $ Left $ "File not found: " ++ path+        return $+          Left $+            llmError (showText $ "File not found: " ++ path) Nothing Nothing    -- \|   --  Loads the raw content of the PDF file and splits it using a character splitter.@@ -100,6 +114,12 @@     if exists       then do         documents <- readPdf path-        return $ Right $ splitText defaultCharacterSplitterOps (pageContent $ mconcat documents)+        return $+          Right $+            splitText+              defaultCharacterSplitterOps+              (pageContent $ mconcat documents)       else-        return $ Left $ "File not found: " ++ path+        return $+          Left $+            llmError (showText $ "File not found: " ++ path) Nothing Nothing

@@ -30,8 +30,10 @@     Embeddings (..)   ) where +import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Text (Text) import Langchain.DocumentLoader.Core+import Langchain.Error (LangchainResult)  {- | Typeclass for embedding models following LangChain's pattern. Converts text/documents into numerical vectors for machine learning tasks.@@ -53,23 +55,31 @@   embedQuery _ _ = return $ Right [0.4, 0.5, 0.6] @ -}-class Embeddings m where-  -- | Convert documents to embedding vectors-  ---  --   Example:-  ---  --   >>> let doc = Document "Hello world" mempty-  --   >>> embedDocuments TestEmbeddings [doc]-  --   Right [[0.1, 0.2, 0.3]]-  embedDocuments :: m -> [Document] -> IO (Either String [[Float]])+class Embeddings embed where+  {- | Convert documents to embedding vectors -  -- | Convert query text to embedding vector-  ---  --   Example:-  ---  --   >>> embedQuery TestEmbeddings "Search query"-  --   Right [0.4, 0.5, 0.6]-  embedQuery :: m -> Text -> IO (Either String [Float])+  Example:++  >>> let doc = Document "Hello world" mempty+  >>> embedDocuments TestEmbeddings [doc]+  Right [[0.1, 0.2, 0.3]]+  -}+  embedDocuments :: embed -> [Document] -> IO (LangchainResult [[Float]])++  embedDocumentsM :: MonadIO m => embed -> [Document] -> m (LangchainResult [[Float]])+  embedDocumentsM embeddings docs = liftIO $ embedDocuments embeddings docs++  {- | Convert query text to embedding vector++  Example:++  >>> embedQuery TestEmbeddings "Search query"+  Right [0.4, 0.5, 0.6]+  -}+  embedQuery :: embed -> Text -> IO (LangchainResult [Float])++  embedQueryM :: MonadIO m => embed -> Text -> m (LangchainResult [Float])+  embedQueryM embeddings query = liftIO $ embedQuery embeddings query  {- $examples Test case patterns:

@@ -0,0 +1,67 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++{- |+Module      : Langchain.Embeddings.Gemini+Description : Gemini integration for text embeddings in LangChain Haskell+Copyright   : (c) 2025 Tushar Adhatrao+License     : MIT+Maintainer  : Tushar Adhatrao <tusharadhatrao@gmail.com>+Stability   : experimental++Gemini implementation of LangChain's embedding interface. Supports document and query+embedding generation through Gemini's OpenAI compatible API.+Checkout docs here: https://ai.google.dev/gemini-api/docs/openai#embeddings+-}+module Langchain.Embeddings.Gemini+  ( -- * Types+    GeminiEmbeddings (..)+  , defaultGeminiEmbeddings+  , module Langchain.Embeddings.Core+  ) where++import Data.Text (Text, unpack)+import GHC.Generics+import Langchain.Embeddings.Core+import Langchain.Embeddings.OpenAI++data GeminiEmbeddings = GeminiEmbeddings+  { apiKey :: Text+  -- ^ Gemini API Key+  , baseUrl :: Maybe String+  -- ^ base url; default "https://generativelanguage.googleapis.com/v1beta/openai"+  , model :: Text+  -- ^ Model name for embeddings+  , dimensions :: Maybe Int+  -- ^ The number of dimensions the resulting output embeddings should have.+  , encodingFormat :: Maybe EncodingFormat+  {- ^ The format to return the embeddings in.+  ^ For now, only float is supported+  -}+  , embeddingsUser :: Maybe Text+  -- ^ A unique identifier representing your end-user, which can help monitor and detect abuse.+  , timeout :: Maybe Int+  -- ^ Override default responsetime out. unit = seconds.+  }+  deriving (Eq, Generic)++instance Show GeminiEmbeddings where+  show GeminiEmbeddings {..} = "GeminiEmbeddings " <> "model " <> unpack model++-- | Default values GeminiEmbeddings, api-key is empty+defaultGeminiEmbeddings :: GeminiEmbeddings+defaultGeminiEmbeddings =+  GeminiEmbeddings+    { apiKey = ""+    , baseUrl = pure "https://generativelanguage.googleapis.com/v1beta/openai"+    , model = "gemini-embedding-001"+    , dimensions = Nothing+    , encodingFormat = Nothing+    , embeddingsUser = Nothing+    , timeout = Nothing+    }++instance Embeddings GeminiEmbeddings where+  embedDocuments GeminiEmbeddings {..} = embedDocuments OpenAIEmbeddings {..}+  embedQuery GeminiEmbeddings {..} = embedQuery OpenAIEmbeddings {..}

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}  {- |@@ -33,13 +34,18 @@ -} module Langchain.Embeddings.Ollama   ( OllamaEmbeddings (..)+  , module Langchain.DocumentLoader.Core   ) where  import Data.Maybe import Data.Ollama.Embeddings+import qualified Data.Ollama.Embeddings as O import Data.Text (Text)+import qualified Data.Text.Lazy as T import Langchain.DocumentLoader.Core import Langchain.Embeddings.Core+import Langchain.Error (llmError)+import Langchain.Utils (showText)  {- | Ollama-specific embedding configuration Contains parameters for controlling:@@ -50,7 +56,7 @@  Example configuration: ->>> OllamaEmbeddings "nomic-embed" (Just False) (Just "1h")+>>> OllamaEmbeddings "nomic-embed" (Just False) (Just 3600) Nothing OllamaEmbeddings {model = "nomic-embed", ...} -} data OllamaEmbeddings = OllamaEmbeddings@@ -58,36 +64,35 @@   -- ^ The name of the Ollama model to use for embeddings   , defaultTruncate :: Maybe Bool   -- ^ Optional flag to truncate input if supported by the API-  , defaultKeepAlive :: Maybe Text-  -- ^ Keep model loaded for specified duration (e.g., "5m")+  , defaultKeepAlive :: Maybe Int+  -- ^ Keep model loaded for specified duration in seconds (e.g., 300 for 5 minutes)+  , modelOptions :: Maybe O.ModelOptions+  -- ^ Optional model parameters (e.g., temperature) as specified in the Modelfile.   }   deriving (Show, Eq) -go :: EmbeddingResp -> Either String [Float]-go embResp =-  case listToMaybe (embedding_ embResp) of-    Nothing -> Left "Embeddings are empty"-    Just x -> Right x- instance Embeddings OllamaEmbeddings where-  -- \| Document embedding implementation [[3]]:+  -- \| Document embedding implementation:   --  Processes each document individually through Ollama's API.   --   --  Example:   --  >>> let doc = Document "Test content" mempty   --  >>> embedDocuments ollamaEmb [doc]   --  Right [[0.1, 0.2, ...], ...]-  --   embedDocuments (OllamaEmbeddings {..}) docs = do     -- For each input text, make an individual API call-    results <--      mapM-        (\doc -> embeddingOps model (pageContent doc) defaultTruncate defaultKeepAlive)-        docs-    -- Combine the results, handling errors appropriately-    return $-      sequence results >>= \resps ->-        mapM go resps+    eRes <-+      embeddingOps+        model+        (map (T.toStrict . pageContent) docs)+        defaultTruncate+        defaultKeepAlive+        modelOptions+        Nothing+        Nothing+    case eRes of+      Left ollamaErr -> return $ Left $ llmError (showText ollamaErr) Nothing Nothing+      Right r -> return $ Right $ respondedEmbeddings r    -- \| Query embedding implementation:   --  Generates vector representation for search queries.@@ -97,10 +102,18 @@   --  Right [0.3, 0.4, ...]   --   embedQuery (OllamaEmbeddings {..}) query = do-    res <- embeddingOps model query defaultTruncate defaultKeepAlive-    case fmap embedding_ res of-      Left err -> pure $ Left err+    res <-+      embeddingOps+        model+        [query]+        defaultTruncate+        defaultKeepAlive+        modelOptions+        Nothing+        Nothing+    case fmap respondedEmbeddings res of+      Left err -> pure $ Left (llmError (showText err) Nothing Nothing)       Right lst ->         case listToMaybe lst of-          Nothing -> pure $ Left "Embeddings are empty"+          Nothing -> pure $ Left (llmError "Embeddings are empty" Nothing Nothing)           Just x -> pure $ Right x

@@ -23,6 +23,7 @@   , textEmbedding3Small   , textEmbedding3Large   , textEmbeddingAda+  , EncodingFormat (..)   ) where  {-@@ -41,11 +42,14 @@ import Data.Aeson import Data.Maybe import Data.Text (Text, unpack)+import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8)+import qualified Data.Text.Lazy as TL import qualified Data.Vector as V import GHC.Generics import Langchain.DocumentLoader.Core import Langchain.Embeddings.Core+import Langchain.Error (llmError) import Network.HTTP.Conduit import Network.HTTP.Simple   ( getResponseBody@@ -70,7 +74,6 @@   , dimensionsReq :: Maybe Int   -- ^ Only supported in text-embedding-3 or later   , encodingFormatReq :: Maybe EncodingFormat-  , embeddingsUserReq :: Maybe Text   }   deriving (Show, Eq, Generic) @@ -89,7 +92,6 @@       , "model" .= modelReq       , "dimensions" .= dimensionsReq       , "encoding_format" .= encodingFormatReq-      , "user" .= embeddingsUserReq       ]  -- Response@@ -101,7 +103,7 @@  data EmbeddingsObject = EmbeddingsObject   { embeddings :: [Float]-  , index :: Int+  , index :: Maybe Int   , objectType :: Text   }   deriving (Eq, Show, Generic)@@ -110,7 +112,7 @@   { objectTypeResp :: Text   , dataList :: [EmbeddingsObject]   , responseModel :: Text-  , usage :: EmbeddingsUsage+  , usage :: Maybe EmbeddingsUsage   }   deriving (Eq, Show, Generic) @@ -125,7 +127,7 @@   parseJSON (Object v) =     EmbeddingsObject       <$> v .: "embedding"-      <*> v .: "index"+      <*> v .:? "index"       <*> v .: "object"   parseJSON _ = error "Parse error, expecting object" @@ -135,23 +137,25 @@       <$> v .: "object"       <*> v .: "data"       <*> v .: "model"-      <*> v .: "usage"+      <*> 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+  , baseUrl :: Maybe String+  -- ^ base url; default "https://api.openai.com/v1"   , model :: Text   -- ^ Model name for embeddings   , dimensions :: Maybe Int-  -- ^ The number of dimensions the resulting output embeddings should have.-  -- ^ Only supported in text-embedding-3 or later+  {- ^ 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.+  {- ^ The format to return the embeddings in.+  ^ For now, only float is supported+  -}   , timeout :: Maybe Int   -- ^ Override default responsetime out. unit = seconds.   }@@ -160,9 +164,12 @@ instance Show OpenAIEmbeddings where   show OpenAIEmbeddings {..} = "OpenAIEmbeddings " <> "model " <> unpack model -openAIEmbeddingsRequest :: OpenAIEmbeddings -> [Text] -> IO (Either String OpenAIEmbeddingsResponse)+openAIEmbeddingsRequest ::+  OpenAIEmbeddings -> [Text] -> IO (Either String OpenAIEmbeddingsResponse) openAIEmbeddingsRequest OpenAIEmbeddings {..} txts = do-  request_ <- parseRequest "https://api.openai.com/v1/embeddings"+  request_ <-+    parseRequest $+      fromMaybe "https://api.openai.com/v1" baseUrl <> "/embeddings"   manager <-     newManager       tlsManagerSettings@@ -170,20 +177,19 @@             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_+        setRequestMethod "POST" $+          setRequestSecure True $+            setRequestHeader "Content-Type" ["application/json"] $+              setRequestHeader "Authorization" ["Bearer " <> encodeUtf8 apiKey] $+                setRequestBodyJSON+                  ( OpenAIEmbeddingsRequest+                      { inputReq = TextList txts+                      , modelReq = model+                      , dimensionsReq = dimensions+                      , encodingFormatReq = encodingFormat+                      }+                  )+                  request_    response <- httpLbs req manager   let status = statusCode $ getResponseStatus response@@ -191,23 +197,29 @@     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)+    else+      return $+        Left $+          "API error: "+            <> show status+            <> " "+            <> show (getResponseBody response)  instance Embeddings OpenAIEmbeddings where   embedDocuments openAIEmbeddings docs = do-    eRes <- openAIEmbeddingsRequest openAIEmbeddings (map pageContent docs)+    eRes <- openAIEmbeddingsRequest openAIEmbeddings (map (TL.toStrict . pageContent) docs)     case eRes of-      Left err -> pure $ Left err+      Left err -> pure $ Left (llmError (T.pack err) Nothing Nothing)       Right (OpenAIEmbeddingsResponse {..}) -> do         pure $ Right $ map embeddings dataList    embedQuery openAIEmbeddings query = do     eRes <- openAIEmbeddingsRequest openAIEmbeddings [query]     case eRes of-      Left err -> pure $ Left err+      Left err -> pure $ Left (llmError (T.pack err) Nothing Nothing)       Right (OpenAIEmbeddingsResponse {..}) -> do         case listToMaybe dataList of-          Nothing -> pure $ Left "Embeddings are empty"+          Nothing -> pure $ Left (llmError "Embeddings are empty" Nothing Nothing)           Just x -> pure $ Right $ embeddings x  -- Helper functions, model name functions@@ -229,9 +241,9 @@ defaultOpenAIEmbeddings =   OpenAIEmbeddings     { apiKey = ""+    , baseUrl = pure "https://api.openai.com/v1"     , model = textEmbedding3Small     , dimensions = Nothing     , encodingFormat = Nothing-    , embeddingsUser = Nothing     , timeout = Nothing     }

@@ -0,0 +1,609 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++{- |+Module      : Langchain.Error+Description : Central error handling for langchain-hs+Copyright   : (c) 2025 Tushar Adhatrao+License     : MIT+Maintainer  : Tushar Adhatrao <tusharadhatrao@gmail.com>+Stability   : experimental++This module provides a comprehensive error handling system for langchain-hs,+replacing the previous `Either String` pattern with a structured, type-safe+approach that follows industry best practices.++The error system includes:++* Structured error types with context and metadata+* Error severity levels and categories+* Utility functions for error construction and handling+* Integration with existing langchain-hs components+* Support for error chaining and context preservation++Example usage:++@+import Langchain.Error++-- Creating errors+let err = llmError "Model timeout" (Just "gpt-4") Nothing++-- Error handling with context+result <- someOperation+case result of+  Left err -> do+    logError err+    handleError err+  Right value -> processValue value++-- Error chaining+chainError "Failed to process document" originalError+@+-}+module Langchain.Error+  ( -- * Error Types+    LangchainError (..)+  , ErrorSeverity (..)+  , ErrorCategory (..)+  , ErrorContext (..)++    -- * Error Construction+  , llmError+  , llmErrorWithContext+  , agentError+  , agentErrorWithContext+  , memoryError+  , memoryErrorWithContext+  , toolError+  , toolErrorWithContext+  , vectorStoreError+  , vectorStoreErrorWithContext+  , documentLoaderError+  , documentLoaderErrorWithContext+  , embeddingError+  , embeddingErrorWithContext+  , runnableError+  , runnableErrorWithContext+  , parsingError+  , parsingErrorWithContext+  , networkError+  , networkErrorWithContext+  , configurationError+  , configurationErrorWithContext+  , validationError+  , validationErrorWithContext+  , internalError+  , internalErrorWithContext++    -- * Error Utilities+  , chainError+  , addContext+  , withErrorContext+  , mapError+  , fromString+  , toString+  , toText+  , logError+  , isRetryable+  , getSeverity+  , getCategory+  , fromStringError+  , fromException+  , liftStringError+  , simpleError+  , catchToLangchainError+  , withContext+  , withContextIO++    -- * Type Aliases+  , LangchainResult+  , LangchainIO++    -- * Re-exports for convenience+  , module Control.Exception+  ) where++import Control.Exception (Exception, SomeException, displayException, try)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Aeson (FromJSON, ToJSON)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time (UTCTime, getCurrentTime)+import GHC.Generics (Generic)+import System.IO (hPutStrLn, stderr)++-- | Severity levels for errors, following industry standards+data ErrorSeverity+  = -- | System-breaking errors that require immediate attention+    Critical+  | -- | Errors that prevent core functionality+    High+  | -- | Errors that degrade functionality but allow continuation+    Medium+  | -- | Minor errors or warnings+    Low+  | -- | Informational messages+    Info+  deriving (Eq, Ord, Show, Generic, ToJSON, FromJSON)++-- | Categories of errors for better organization and handling+data ErrorCategory+  = -- | Language model related errors+    LLMError+  | -- | Agent execution errors+    AgentError+  | -- | Memory management errors+    MemoryError+  | -- | Tool execution errors+    ToolError+  | -- | Vector store operation errors+    VectorStoreError+  | -- | Document loading errors+    DocumentLoaderError+  | -- | Embedding generation errors+    EmbeddingError+  | -- | Runnable execution errors+    RunnableError+  | -- | Data parsing and validation errors+    ParsingError+  | -- | Network and HTTP errors+    NetworkError+  | -- | Configuration and setup errors+    ConfigurationError+  | -- | Input validation errors+    ValidationError+  | -- | Internal system errors+    InternalError+  deriving (Eq, Show, Generic, ToJSON, FromJSON)++-- | Additional context information for errors+data ErrorContext = ErrorContext+  { contextComponent :: Maybe Text+  -- ^ Component where error occurred+  , contextOperation :: Maybe Text+  -- ^ Operation being performed+  , contextInput :: Maybe Text+  -- ^ Input that caused the error+  , contextMetadata :: [(Text, Text)]+  -- ^ Additional metadata+  , contextTimestamp :: UTCTime+  -- ^ When the error occurred+  }+  deriving (Eq, Show, Generic, ToJSON, FromJSON)++-- | The central error type for langchain-hs+data LangchainError = LangchainError+  { errorMessage :: Text+  -- ^ Human-readable error message+  , errorSeverity :: ErrorSeverity+  -- ^ Severity level+  , errorCategory :: ErrorCategory+  -- ^ Error category+  , errorContext :: Maybe ErrorContext+  -- ^ Additional context+  , errorCause :: Maybe LangchainError+  -- ^ Chained/nested error+  , errorCode :: Maybe Text+  -- ^ Optional error code+  }+  deriving (Eq, Show, Generic, ToJSON, FromJSON)++instance Exception LangchainError where+  displayException LangchainError {..} =+    T.unpack $+      T.unlines $+        filter+          (not . T.null)+          [ "["+              <> T.pack (show errorSeverity)+              <> "] "+              <> T.pack (show errorCategory)+              <> ": "+              <> errorMessage+          , maybe "" ("Error Code: " <>) errorCode+          , maybe "" formatContext errorContext+          , maybe "" (\cause -> "Caused by: " <> T.pack (show cause)) errorCause+          ]+    where+      formatContext ErrorContext {..} =+        T.unlines $+          filter+            (not . T.null)+            [ maybe "" ("Component: " <>) contextComponent+            , maybe "" ("Operation: " <>) contextOperation+            , maybe "" ("Input: " <>) contextInput+            , if null contextMetadata then "" else "Metadata: " <> T.pack (show contextMetadata)+            , "Timestamp: " <> T.pack (show contextTimestamp)+            ]++-- | Type alias for results that can fail with LangchainError+type LangchainResult a = Either LangchainError a++-- | Type alias for IO operations that can fail with LangchainError+type LangchainIO a = IO (LangchainResult a)++-- | Create an LLM-related error+llmError :: Text -> Maybe Text -> Maybe Text -> LangchainError+llmError msg _model _operation =+  LangchainError+    { errorMessage = msg+    , errorSeverity = High+    , errorCategory = LLMError+    , errorContext = Nothing+    , errorCause = Nothing+    , errorCode = Nothing+    }++-- | Create an LLM error with context+llmErrorWithContext ::+  Text ->+  Maybe Text ->+  Maybe Text ->+  ErrorContext ->+  LangchainError+llmErrorWithContext msg model operation ctx =+  (llmError msg model operation)+    { errorContext =+        Just ctx {contextComponent = model, contextOperation = operation}+    }++-- | Create an agent-related error+agentError :: Text -> Maybe Text -> Maybe Text -> LangchainError+agentError msg _agentType _operation =+  LangchainError+    { errorMessage = msg+    , errorSeverity = High+    , errorCategory = AgentError+    , errorContext = Nothing+    , errorCause = Nothing+    , errorCode = Nothing+    }++-- | Create an agent error with context+agentErrorWithContext :: Text -> Maybe Text -> Maybe Text -> ErrorContext -> LangchainError+agentErrorWithContext msg agentType operation ctx =+  (agentError msg agentType operation)+    { errorContext = Just ctx {contextComponent = agentType, contextOperation = operation}+    }++-- | Create a memory-related error+memoryError :: Text -> Maybe Text -> Maybe Text -> LangchainError+memoryError msg _memoryType _operation =+  LangchainError+    { errorMessage = msg+    , errorSeverity = Medium+    , errorCategory = MemoryError+    , errorContext = Nothing+    , errorCause = Nothing+    , errorCode = Nothing+    }++-- | Create a memory error with context+memoryErrorWithContext :: Text -> Maybe Text -> Maybe Text -> ErrorContext -> LangchainError+memoryErrorWithContext msg memoryType operation ctx =+  (memoryError msg memoryType operation)+    { errorContext = Just ctx {contextComponent = memoryType, contextOperation = operation}+    }++-- | Create a tool-related error+toolError :: Text -> Maybe Text -> Maybe Text -> LangchainError+toolError msg _toolName _operation =+  LangchainError+    { errorMessage = msg+    , errorSeverity = High+    , errorCategory = ToolError+    , errorContext = Nothing+    , errorCause = Nothing+    , errorCode = Nothing+    }++-- | Create a tool error with context+toolErrorWithContext :: Text -> Maybe Text -> Maybe Text -> ErrorContext -> LangchainError+toolErrorWithContext msg toolName operation ctx =+  (toolError msg toolName operation)+    { errorContext = Just ctx {contextComponent = toolName, contextOperation = operation}+    }++-- | Create a vector store error+vectorStoreError :: Text -> Maybe Text -> Maybe Text -> LangchainError+vectorStoreError msg _storeType _operation =+  LangchainError+    { errorMessage = msg+    , errorSeverity = High+    , errorCategory = VectorStoreError+    , errorContext = Nothing+    , errorCause = Nothing+    , errorCode = Nothing+    }++-- | Create a vector store error with context+vectorStoreErrorWithContext :: Text -> Maybe Text -> Maybe Text -> ErrorContext -> LangchainError+vectorStoreErrorWithContext msg storeType operation ctx =+  (vectorStoreError msg storeType operation)+    { errorContext = Just ctx {contextComponent = storeType, contextOperation = operation}+    }++-- | Create a document loader error+documentLoaderError :: Text -> Maybe Text -> Maybe Text -> LangchainError+documentLoaderError msg _loaderType _operation =+  LangchainError+    { errorMessage = msg+    , errorSeverity = Medium+    , errorCategory = DocumentLoaderError+    , errorContext = Nothing+    , errorCause = Nothing+    , errorCode = Nothing+    }++-- | Create a document loader error with context+documentLoaderErrorWithContext :: Text -> Maybe Text -> Maybe Text -> ErrorContext -> LangchainError+documentLoaderErrorWithContext msg loaderType operation ctx =+  (documentLoaderError msg loaderType operation)+    { errorContext = Just ctx {contextComponent = loaderType, contextOperation = operation}+    }++-- | Create an embedding error+embeddingError :: Text -> Maybe Text -> Maybe Text -> LangchainError+embeddingError msg _embeddingType _operation =+  LangchainError+    { errorMessage = msg+    , errorSeverity = High+    , errorCategory = EmbeddingError+    , errorContext = Nothing+    , errorCause = Nothing+    , errorCode = Nothing+    }++-- | Create an embedding error with context+embeddingErrorWithContext :: Text -> Maybe Text -> Maybe Text -> ErrorContext -> LangchainError+embeddingErrorWithContext msg embeddingType operation ctx =+  (embeddingError msg embeddingType operation)+    { errorContext = Just ctx {contextComponent = embeddingType, contextOperation = operation}+    }++-- | Create a runnable error+runnableError :: Text -> Maybe Text -> Maybe Text -> LangchainError+runnableError msg _runnableType _operation =+  LangchainError+    { errorMessage = msg+    , errorSeverity = High+    , errorCategory = RunnableError+    , errorContext = Nothing+    , errorCause = Nothing+    , errorCode = Nothing+    }++-- | Create a runnable error with context+runnableErrorWithContext :: Text -> Maybe Text -> Maybe Text -> ErrorContext -> LangchainError+runnableErrorWithContext msg runnableType operation ctx =+  (runnableError msg runnableType operation)+    { errorContext = Just ctx {contextComponent = runnableType, contextOperation = operation}+    }++-- | Create a parsing error+parsingError :: Text -> Maybe Text -> Maybe Text -> LangchainError+parsingError msg _parserType _input =+  LangchainError+    { errorMessage = msg <> fromMaybe "" _parserType+    , errorSeverity = Medium+    , errorCategory = ParsingError+    , errorContext = Nothing+    , errorCause = Nothing+    , errorCode = _input+    }++-- | Create a parsing error with context+parsingErrorWithContext :: Text -> Maybe Text -> Maybe Text -> ErrorContext -> LangchainError+parsingErrorWithContext msg parserType input ctx =+  (parsingError msg parserType input)+    { errorContext = Just ctx {contextComponent = parserType, contextInput = input}+    }++-- | Create a network error+networkError :: Text -> Maybe Text -> Maybe Text -> LangchainError+networkError msg _endpoint _operation =+  LangchainError+    { errorMessage = msg+    , errorSeverity = High+    , errorCategory = NetworkError+    , errorContext = Nothing+    , errorCause = Nothing+    , errorCode = Nothing+    }++-- | Create a network error with context+networkErrorWithContext :: Text -> Maybe Text -> Maybe Text -> ErrorContext -> LangchainError+networkErrorWithContext msg endpoint operation ctx =+  (networkError msg endpoint operation)+    { errorContext = Just ctx {contextComponent = endpoint, contextOperation = operation}+    }++-- | Create a configuration error+configurationError :: Text -> Maybe Text -> Maybe Text -> LangchainError+configurationError msg _configKey _operation =+  LangchainError+    { errorMessage = msg+    , errorSeverity = Critical+    , errorCategory = ConfigurationError+    , errorContext = Nothing+    , errorCause = Nothing+    , errorCode = Nothing+    }++-- | Create a configuration error with context+configurationErrorWithContext :: Text -> Maybe Text -> Maybe Text -> ErrorContext -> LangchainError+configurationErrorWithContext msg configKey operation ctx =+  (configurationError msg configKey operation)+    { errorContext = Just ctx {contextComponent = configKey, contextOperation = operation}+    }++-- | Create a validation error+validationError :: Text -> Maybe Text -> Maybe Text -> LangchainError+validationError msg _field _input =+  LangchainError+    { errorMessage = msg+    , errorSeverity = Medium+    , errorCategory = ValidationError+    , errorContext = Nothing+    , errorCause = Nothing+    , errorCode = Nothing+    }++-- | Create a validation error with context+validationErrorWithContext :: Text -> Maybe Text -> Maybe Text -> ErrorContext -> LangchainError+validationErrorWithContext msg field input ctx =+  (validationError msg field input)+    { errorContext = Just ctx {contextComponent = field, contextInput = input}+    }++-- | Create an internal error+internalError :: Text -> Maybe Text -> Maybe Text -> LangchainError+internalError msg _component _operation =+  LangchainError+    { errorMessage = msg+    , errorSeverity = Critical+    , errorCategory = InternalError+    , errorContext = Nothing+    , errorCause = Nothing+    , errorCode = Nothing+    }++-- | Create an internal error with context+internalErrorWithContext :: Text -> Maybe Text -> Maybe Text -> ErrorContext -> LangchainError+internalErrorWithContext msg component operation ctx =+  (internalError msg component operation)+    { errorContext = Just ctx {contextComponent = component, contextOperation = operation}+    }++-- | Chain an error with a new message, preserving the original as the cause+chainError :: Text -> LangchainError -> LangchainError+chainError msg originalError =+  LangchainError+    { errorMessage = msg+    , errorSeverity = errorSeverity originalError+    , errorCategory = errorCategory originalError+    , errorContext = errorContext originalError+    , errorCause = Just originalError+    , errorCode = errorCode originalError+    }++-- | Add context to an existing error+addContext :: ErrorContext -> LangchainError -> LangchainError+addContext ctx err = err {errorContext = Just ctx}++-- | Execute an action with error context, automatically adding context to any errors+withErrorContext :: MonadIO m => ErrorContext -> LangchainIO a -> m (LangchainResult a)+withErrorContext ctx action = liftIO $ do+  result <- action+  case result of+    Left err -> return $ Left $ addContext ctx err+    Right val -> return $ Right val++-- | Map a function over the error in a result+mapError :: (LangchainError -> LangchainError) -> LangchainResult a -> LangchainResult a+mapError f (Left err) = Left (f err)+mapError _ (Right val) = Right val++-- | Convert a String to LangchainError+fromString :: String -> LangchainError+fromString str = internalError (T.pack str) Nothing Nothing++-- | Convert LangchainError to String+toString :: LangchainError -> String+toString = displayException++-- | Convert LangchainError to Text+toText :: LangchainError -> Text+toText = T.pack . toString++-- | Log an error to stderr (can be extended to use proper logging)+logError :: MonadIO m => LangchainError -> m ()+logError err = liftIO $ hPutStrLn stderr $ toString err++-- | Check if an error is retryable based on its category and severity+isRetryable :: LangchainError -> Bool+isRetryable LangchainError {..} = case errorCategory of+  NetworkError -> errorSeverity <= High+  LLMError -> errorSeverity <= Medium+  VectorStoreError -> errorSeverity <= Medium+  EmbeddingError -> errorSeverity <= Medium+  ToolError -> errorSeverity <= Medium+  _ -> False++-- | Get the severity of an error+getSeverity :: LangchainError -> ErrorSeverity+getSeverity = errorSeverity++-- | Get the category of an error+getCategory :: LangchainError -> ErrorCategory+getCategory = errorCategory++-- | Convert a String error to LangchainError (for backward compatibility)+fromStringError :: String -> LangchainError+fromStringError = fromString++-- | Convert an IO exception to LangchainError+fromException :: SomeException -> LangchainError+fromException ex = internalError (T.pack $ displayException ex) Nothing Nothing++-- | Lift an Either String to LangchainResult+liftStringError :: Either String a -> LangchainResult a+liftStringError (Left err) = Left (fromString err)+liftStringError (Right val) = Right val++-- | Create a simple error with just a message (uses InternalError category)+simpleError :: Text -> LangchainError+simpleError msg = internalError msg Nothing Nothing++-- | Catch IO exceptions and convert them to LangchainError+catchToLangchainError :: IO a -> IO (LangchainResult a)+catchToLangchainError action = do+  result <- try action+  case result of+    Left ex -> return $ Left $ fromException ex+    Right val -> return $ Right val++-- | Run an action and add context to any errors+withContext :: Text -> Text -> LangchainResult a -> LangchainResult a+withContext component operation result = case result of+  Left err ->+    case errorContext err of+      Just ctx ->+        Left $+          err+            { errorContext =+                Just $+                  ErrorContext+                    { contextComponent = Just component+                    , contextOperation = Just operation+                    , contextInput = Nothing+                    , contextMetadata = []+                    , contextTimestamp = contextTimestamp ctx+                    }+            }+      Nothing -> Left err+  Right val -> Right val++-- | Run an action and add context to any errors (IO version)+withContextIO :: MonadIO m => Text -> Text -> LangchainResult a -> m (LangchainResult a)+withContextIO component operation result = case result of+  Left err -> do+    now <- liftIO getCurrentTime+    return $+      Left $+        err+          { errorContext =+              Just $+                ErrorContext+                  { contextComponent = Just component+                  , contextOperation = Just operation+                  , contextInput = Nothing+                  , contextMetadata = []+                  , contextTimestamp = now+                  }+          }+  Right val -> return $ Right val

@@ -1,22 +1,23 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}  {- | Module:      Langchain.LLM.Core Copyright:   (c) 2025 Tushar Adhatrao License:     MIT-Description: Core implementation of langchain chat models+Description: Core implementation of langchain LLMs Maintainer:  Tushar Adhatrao <tusharadhatrao@gmail.com> Stability:   experimental  This module provides the core types and typeclasses for the Langchain library in Haskell,-which is designed to facilitate interaction with language models (LLMs). It defines a standardized-interface that allows different LLM implementations to be used interchangeably, promoting code reuse-and modularity.+which is designed to facilitate interaction with language models (LLMs). +It defines a standardized interface that allows different LLM implementations+to be used interchangeably, promoting code reuse and modularity.+ The main components include:  * The 'LLM' typeclass, which defines the interface for language models.@@ -36,18 +37,27 @@     -- * Parameters   , Message (..)   , Role (..)-  , ChatMessage+  , ChatHistory   , MessageData (..)+  , ToolCall (..)+  , ToolFunction (..)   , StreamHandler (..)+  , MessageConvertible (..)      -- * Default Values+  , defaultMessage   , defaultMessageData   ) where +import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Aeson+import qualified Data.Aeson.KeyMap as KM import Data.List.NonEmpty+import qualified Data.Map as HM import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8) import GHC.Generics+import Langchain.Error (LangchainResult)  {- | Callbacks for handling streaming responses from a language model. This allows real-time processing of tokens as they are generated and an action@@ -61,8 +71,8 @@   } @ -}-data StreamHandler = StreamHandler-  { onToken :: Text -> IO ()+data StreamHandler tokenType = StreamHandler+  { onToken :: tokenType -> IO ()   -- ^ Action to perform for each token received   , onComplete :: IO ()   -- ^ Action to perform when streaming is complete@@ -78,11 +88,17 @@     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)+  | -- | Developer role for developer messages. Specific to only some integrations+    Developer+  | -- | Function role for function call messages. Specific to only some integrations+    Function+  deriving+    ( Eq+    , Show+    , Generic+    , ToJSON+    , FromJSON+    )  {- | Represents a message in a conversation, including the sender's role, content, and additional metadata.@@ -107,6 +123,59 @@   }   deriving (Eq, Show) +-- Function call details+data ToolFunction = ToolFunction+  { toolFunctionName :: Text+  , toolFunctionArguments :: HM.Map Text Value+  }+  deriving (Show, Eq)++-- Main tool call structure+data ToolCall = ToolCall+  { toolCallId :: Text+  , toolCallType :: Text+  , toolCallFunction :: ToolFunction+  }+  deriving (Show, Eq)++-- ToJSON instance for ToolFunction+instance ToJSON ToolFunction where+  toJSON (ToolFunction name args) =+    object+      [ "name" .= name+      , "arguments" .= args+      ]++-- FromJSON instance for ToolFunction+instance FromJSON ToolFunction where+  parseJSON = withObject "ToolFunction" $ \obj -> do+    name <- obj .: "name"+    argsVal <- obj .: "arguments"+    args <- case argsVal of+      Object o -> pure $ KM.toMapText o+      String s -> case decodeStrict (encodeUtf8 s) of+        Just (Object o) -> pure $ KM.toMapText o+        _ -> fail "ToolFunction.arguments: expected object or JSON-encoded object string"+      _ -> fail "ToolFunction.arguments: expected object or string"+    return $ ToolFunction name args++-- ToJSON instance for ToolCall+instance ToJSON ToolCall where+  toJSON (ToolCall callId callType func) =+    object+      [ "id" .= callId+      , "type" .= callType+      , "function" .= func+      ]++-- FromJSON instance for ToolCall+instance FromJSON ToolCall where+  parseJSON = withObject "ToolCall" $ \obj -> do+    callId <- obj .: "id"+    callType <- obj .: "type"+    func <- obj .: "function"+    return $ ToolCall callId callType func+ {- | Additional data for a message, such as a name or tool calls. This type is designed for extensibility, allowing new fields to be added without breaking changes. Use 'defaultMessageData' for typical usage.@@ -114,8 +183,12 @@ data MessageData = MessageData   { name :: Maybe Text   -- ^ Optional name associated with the message-  , toolCalls :: Maybe [Text]+  , toolCalls :: Maybe [ToolCall]   -- ^ Optional list of tool calls invoked by the message+  , messageImages :: Maybe [Text]+  -- ^ Base64 encoded image data list+  , thinking :: Maybe Text+  -- ^ Thinking   }   deriving (Eq, Show) @@ -125,6 +198,8 @@     object       [ "name" .= name       , "tool_calls" .= toolCalls+      , "images" .= messageImages+      , "thinking" .= thinking       -- Add more fields as they are added       ] @@ -134,10 +209,21 @@     MessageData       <$> v .:? "name"       <*> v .:? "tool_calls"+      <*> v .:? "images"+      <*> v .:? "thinking"  -- | Type alias for NonEmpty Message-type ChatMessage = NonEmpty Message+type ChatHistory = NonEmpty Message +-- | Default message with User role and no content.+defaultMessage :: Message+defaultMessage =+  Message+    { role = User+    , content = ""+    , messageData = defaultMessageData+    }+ {- | Default message data with all fields set to Nothing. Use this for standard messages without additional metadata -}@@ -146,29 +232,90 @@   MessageData     { name = Nothing     , toolCalls = Nothing+    , messageImages = Nothing+    , thinking = Nothing     }  -- | Typeclass that all ChatModels should interface with-class LLM m where+class LLM llm where   -- | Define the Parameter type for your LLM model.-  type LLMParams m+  type LLMStreamTokenType llm -  -  -- | 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 (LLMParams m) -- ^ Optional configuration parameters.-    -> IO (Either String Text)+  type LLMParams llm -  -- | Chat with the language model using a sequence of messages.-  -- Suitable for multi-turn conversations; returns either an error or the response.-  ---  chat :: m -- ^ The type of the language model instance.-    -> ChatMessage -- ^ A non-empty list of messages to send to the model.-    -> Maybe (LLMParams m) -- ^ Optional configuration parameters.-    -> IO (Either String Text) -- ^ The result of the chat, either an error or the response text.+  {- | Invoke the language model with a single prompt.+       Suitable for simple queries; returns either an error or generated text.+  -}+  generate ::+    -- | The type of the language model instance.+    llm ->+    -- | The prompt to send to the model.+    Text ->+    -- | Optional configuration parameters.+    Maybe (LLMParams llm) ->+    IO (LangchainResult Text) -  -- | 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 (LLMParams m) -> IO (Either String ())+  {- | Chat with the language model using a sequence of messages.+  Suitable for multi-turn conversations; returns either an error or the response.+  -}+  chat ::+    -- | The type of the language model instance.+    llm ->+    -- | A non-empty list of messages to send to the model.+    ChatHistory ->+    -- | Optional configuration parameters.+    Maybe (LLMParams llm) ->+    -- | The result of the chat, either an error or the response text.+    IO (LangchainResult Message)++  {- | Stream responses from the language model for a sequence of messages.+  Uses callbacks to process tokens in real-time; returns either an error or unit.+  -}+  stream ::+    llm ->+    ChatHistory ->+    StreamHandler (LLMStreamTokenType llm) ->+    Maybe (LLMParams llm) ->+    IO (LangchainResult ())++  -- Default implementations++  -- | MonadIO version of generate+  generateM ::+    MonadIO m =>+    -- | The type of the language model instance.+    llm ->+    -- | The prompt to send to the model.+    Text ->+    -- | Optional configuration parameters.+    Maybe (LLMParams llm) ->+    m (LangchainResult Text)+  generateM llm prompt mbParams = liftIO $ generate llm prompt mbParams++  -- | MonadIO version of chat+  chatM ::+    MonadIO m =>+    -- | The type of the language model instance.+    llm ->+    -- | A non-empty list of messages to send to the model.+    ChatHistory ->+    -- | Optional configuration parameters.+    Maybe (LLMParams llm) ->+    -- | The result of the chat, either an error or the response text.+    m (LangchainResult Message)+  chatM llm chatHistory mbParams = liftIO $ chat llm chatHistory mbParams++  -- | MonadIO version of stream+  streamM ::+    MonadIO m =>+    llm ->+    ChatHistory ->+    StreamHandler (LLMStreamTokenType llm) ->+    Maybe (LLMParams llm) ->+    m (LangchainResult ())+  streamM llm chatHistory sHandler mbParams =+    liftIO $ stream llm chatHistory sHandler mbParams++class MessageConvertible a where+  to :: Message -> a+  from :: a -> Message

@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}++{- |+Module      : Langchain.LLM.Deepseek+Description : Deepseek integration for LangChain Haskell+Copyright   : (c) 2025 Tushar Adhatrao+License     : MIT+Maintainer  : Tushar Adhatrao <tusharadhatrao@gmail.com>+Stability   : experimental++This module provides the 'Deepseek' data type and implements the 'LLM' typeclass for interacting with Deepseek's language models.+It supports generating text, handling chat interactions, and streaming responses using Deepseek's API.++This implementation uses the OpenAI-compatible interface with baseUrl as "https://api.deepseek.com".++For more information on Deepseek's API, see: <https://platform.deepseek.com/api-docs/>+-}+module Langchain.LLM.Deepseek+  ( Deepseek (..)+  , module Langchain.LLM.Core+  ) where++import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Langchain.Callback+import Langchain.LLM.Core+import qualified Langchain.LLM.Core as LLM+import Langchain.LLM.OpenAICompatible (OpenAICompatible (..))+import qualified Langchain.Runnable.Core as Run+import qualified OpenAI.V1.Chat.Completions as OpenAIV1++data Deepseek = Deepseek+  { apiKey :: Text+  -- ^ The API key for authenticating with Deepseek's services.+  , callbacks :: [Callback]+  -- ^ A list of callbacks for handling events during LLM operations.+  , baseUrl :: Maybe String+  -- ^ Base url; default "https://api.deepseek.com"+  }++instance Show Deepseek where+  show _ = "Deepseek"++toOpenAI :: Deepseek -> OpenAICompatible+toOpenAI Deepseek {..} =+  OpenAICompatible+    { apiKey = apiKey+    , callbacks = callbacks+    , baseUrl = Just $ fromMaybe "https://api.deepseek.com" baseUrl+    , providerName = "Deepseek"+    }++instance LLM.LLM Deepseek where+  type LLMParams Deepseek = OpenAIV1.CreateChatCompletion+  type LLMStreamTokenType Deepseek = OpenAIV1.ChatCompletionChunk++  generate deepseek = LLM.generate (toOpenAI deepseek)+  chat deepseek = LLM.chat (toOpenAI deepseek)+  stream deepseek = LLM.stream (toOpenAI deepseek)++instance Run.Runnable Deepseek where+  type RunnableInput Deepseek = (ChatHistory, Maybe OpenAIV1.CreateChatCompletion)+  type RunnableOutput Deepseek = LLM.Message++  invoke = uncurry . chat

@@ -0,0 +1,104 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++{- |+Module      : Langchain.LLM.Gemini+Description : Google Gemini integration for LangChain Haskell+Copyright   : (c) 2025 Tushar Adhatrao+License     : MIT+Maintainer  : Tushar Adhatrao <tusharadhatrao@gmail.com>+Stability   : experimental++This module provides the 'Gemini' data type and implements the 'LLM' typeclass for interacting+with Google's Gemini language models through OpenAI-compatible API endpoints.++The 'Gemini' type encapsulates the API key, model name, and callbacks for event handling.+The 'LLM' instance methods ('generate', 'chat', 'stream') allow for seamless integration+with LangChain's processing pipelines.++For more information on Gemini API, see: <https://ai.google.dev/gemini-api/docs>++Notes:+* Gemini only supports base64 encoded image content. Check out examples.+* Uses OpenAI-compatible endpoint: https://ai.google.dev/gemini-api/docs/openai++Example usage:++@+import Data.Text (Text)+import qualified Langchain.LLM.Core as LLM+import Langchain.LLM.Gemini (Gemini(..), defaultGemini)++main :: IO()+main = do+  let gemini = defaultGemini { apiKey = "your-api-key" }+  result <- LLM.generate gemini "Explain functional programming" Nothing+  case result of+    Left err -> putStrLn $ "Error: " ++ show err+    Right response -> print response+@+-}+module Langchain.LLM.Gemini+  ( Gemini (..)+  , defaultGemini+  , module Langchain.LLM.Core+  ) where++import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Langchain.Callback+import Langchain.LLM.Core+import qualified Langchain.LLM.Core as LLM+import Langchain.LLM.OpenAICompatible (OpenAICompatible)+import qualified Langchain.LLM.OpenAICompatible as OpenAICompatible+import qualified Langchain.Runnable.Core as Run+import qualified OpenAI.V1.Chat.Completions as OpenAIV1++data Gemini = Gemini+  { apiKey :: Text+  -- ^ The API key for authenticating with Gemini's services.+  , callbacks :: [Callback]+  -- ^ A list of callbacks for handling events during LLM operations.+  , baseUrl :: Maybe String+  -- ^ Base url; default "https://generativelanguage.googleapis.com/v1beta/openai"+  }++instance Show Gemini where+  show _ = "Gemini"++toOpenAI :: Gemini -> OpenAICompatible+toOpenAI Gemini {..} =+  OpenAICompatible.OpenAICompatible+    { apiKey = apiKey+    , callbacks = callbacks+    , baseUrl =+        Just $+          fromMaybe+            "https://generativelanguage.googleapis.com/v1beta/openai"+            baseUrl+    , providerName = "Gemini"+    }++instance LLM.LLM Gemini where+  type LLMParams Gemini = OpenAIV1.CreateChatCompletion+  type LLMStreamTokenType Gemini = OpenAIV1.ChatCompletionChunk++  generate = LLM.generate . toOpenAI+  chat = LLM.chat . toOpenAI+  stream = LLM.stream . toOpenAI++instance Run.Runnable Gemini where+  type RunnableInput Gemini = (ChatHistory, Maybe OpenAIV1.CreateChatCompletion)+  type RunnableOutput Gemini = LLM.Message++  invoke = uncurry . chat++defaultGemini :: Gemini+defaultGemini =+  Gemini+    { apiKey = ""+    , callbacks = []+    , baseUrl = Just "https://generativelanguage.googleapis.com/v1beta/openai"+    }

@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-}@@ -25,13 +26,18 @@      -- * Functions   , defaultHuggingfaceParams-  , Huggingface.defaultMessage+  , Huggingface.defaultHugginfaceMessage++    -- * Re-export+  , module LLM   ) where  import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Text (Text, unpack)+import qualified Data.Text as T import Langchain.Callback+import Langchain.Error (llmError) import Langchain.LLM.Core as LLM import qualified Langchain.LLM.Internal.Huggingface as Huggingface @@ -92,6 +98,7 @@  instance LLM Huggingface where   type LLMParams Huggingface = HuggingfaceParams+  type LLMStreamTokenType Huggingface = Text    generate Huggingface {..} prompt mbHuggingfaceParams = do     eRes <-@@ -100,35 +107,41 @@         Huggingface.defaultHuggingfaceChatCompletionRequest           { Huggingface.provider = provider           , Huggingface.messages =-              [Huggingface.defaultMessage {Huggingface.content = Huggingface.TextContent prompt}]+              [ Huggingface.defaultHugginfaceMessage+                  { Huggingface.content = Huggingface.TextContent prompt+                  }+              ]           , Huggingface.model = modelName           , Huggingface.stream = False-          , Huggingface.maxTokens = maybe Nothing maxTokens mbHuggingfaceParams-          , Huggingface.frequencyPenalty = maybe Nothing frequencyPenalty mbHuggingfaceParams+          , Huggingface.maxTokens = maxTokens =<< mbHuggingfaceParams+          , Huggingface.frequencyPenalty = frequencyPenalty =<< mbHuggingfaceParams           , -- , Huggingface.logProbs = maybe Nothing logProbs mbHuggingfaceParams-            Huggingface.presencePenalty = maybe Nothing presencePenalty mbHuggingfaceParams+            Huggingface.presencePenalty = presencePenalty =<< mbHuggingfaceParams           , -- , Huggingface.seed = maybe Nothing seed mbHuggingfaceParams-            Huggingface.stop = maybe Nothing stop mbHuggingfaceParams-          , Huggingface.temperature = maybe Nothing temperature mbHuggingfaceParams+            Huggingface.stop = stop =<< mbHuggingfaceParams+          , Huggingface.temperature = 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.topP = topP =<< mbHuggingfaceParams+          , Huggingface.timeout = timeout =<< mbHuggingfaceParams           -- , Huggingface.streamOptions = maybe Nothing streamOptions mbHuggingfaceParams           -- , Huggingface.responseFormat = maybe Nothing responseFormat mbHuggingfaceParams           -- , Huggingface.tools = maybe Nothing tools mbHuggingfaceParams           -- , Huggingface.toolChoice = maybe Nothing toolChoice mbHuggingfaceParams           }     case eRes of-      Left err -> return $ Left err+      Left err -> return $ Left (llmError (T.pack err) Nothing Nothing)       Right r -> do         case listToMaybe ((\Huggingface.ChatCompletionResponse {..} -> choices) r) of-          Nothing -> return $ Left "Did not received any response"+          Nothing ->+            return $+              Left+                (llmError "Did not received any response" Nothing Nothing)           Just resp ->             let Huggingface.Message {..} = Huggingface.message resp              in pure $                   Right $-                    ( \c -> case c of+                    ( \case                         Huggingface.TextContent t -> t                         _ -> ""                     )@@ -143,65 +156,64 @@           , Huggingface.messages = toHuggingfaceMessages msgs           , Huggingface.model = modelName           , Huggingface.stream = False-          , Huggingface.maxTokens = maybe Nothing maxTokens mbHuggingfaceParams-          , Huggingface.frequencyPenalty = maybe Nothing frequencyPenalty mbHuggingfaceParams+          , Huggingface.maxTokens = maxTokens =<< mbHuggingfaceParams+          , Huggingface.frequencyPenalty = frequencyPenalty =<< mbHuggingfaceParams           , -- , Huggingface.logProbs = maybe Nothing logProbs mbHuggingfaceParams-            Huggingface.presencePenalty = maybe Nothing presencePenalty mbHuggingfaceParams+            Huggingface.presencePenalty = presencePenalty =<< mbHuggingfaceParams           , -- , Huggingface.seed = maybe Nothing seed mbHuggingfaceParams-            Huggingface.stop = maybe Nothing stop mbHuggingfaceParams-          , Huggingface.temperature = maybe Nothing temperature mbHuggingfaceParams+            Huggingface.stop = stop =<< mbHuggingfaceParams+          , Huggingface.temperature = 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.topP = topP =<< mbHuggingfaceParams+          , Huggingface.timeout = timeout =<< mbHuggingfaceParams           -- , Huggingface.streamOptions = maybe Nothing streamOptions mbHuggingfaceParams           -- , Huggingface.responseFormat = maybe Nothing responseFormat mbHuggingfaceParams           -- , Huggingface.tools = maybe Nothing tools mbHuggingfaceParams           -- , Huggingface.toolChoice = maybe Nothing toolChoice mbHuggingfaceParams           }     case eRes of-      Left err -> return $ Left err+      Left err -> return $ Left $ llmError (T.pack err) Nothing Nothing       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+        case listToMaybe+          ((\Huggingface.ChatCompletionResponse {..} -> choices) r) of+          Nothing ->+            return $+              Left (llmError "Did not received any response" Nothing Nothing)+          Just resp -> return $ Right $ from (Huggingface.message resp)    stream Huggingface {..} msgs LLM.StreamHandler {..} mbHuggingfaceParams = do-    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-        }+    eRes <-+      Huggingface.createChatCompletionStream+        apiKey+        Huggingface.defaultHuggingfaceChatCompletionRequest+          { Huggingface.provider = provider+          , Huggingface.messages = toHuggingfaceMessages msgs+          , Huggingface.model = modelName+          , Huggingface.stream = True+          , Huggingface.maxTokens = maxTokens =<< mbHuggingfaceParams+          , Huggingface.frequencyPenalty = frequencyPenalty =<< mbHuggingfaceParams+          , -- , Huggingface.logProbs = maybe Nothing logProbs mbHuggingfaceParams+            Huggingface.presencePenalty = presencePenalty =<< mbHuggingfaceParams+          , -- , Huggingface.seed = maybe Nothing seed mbHuggingfaceParams+            Huggingface.stop = stop =<< mbHuggingfaceParams+          , Huggingface.temperature = temperature =<< mbHuggingfaceParams+          , -- , Huggingface.toolPrompt = maybe Nothing toolPrompt mbHuggingfaceParams+            -- , Huggingface.topLogprobs = maybe Nothing topLogProbs mbHuggingfaceParams+            Huggingface.topP = topP =<< mbHuggingfaceParams+          , Huggingface.timeout = timeout =<< mbHuggingfaceParams+          -- , Huggingface.streamOptions = maybe Nothing streamOptions mbHuggingfaceParams+          -- , Huggingface.responseFormat = maybe Nothing responseFormat mbHuggingfaceParams+          -- , Huggingface.tools = maybe Nothing tools mbHuggingfaceParams+          -- , Huggingface.toolChoice = maybe Nothing toolChoice mbHuggingfaceParams+          }+        Huggingface.HuggingfaceStreamHandler+          { Huggingface.onComplete = onComplete+          , Huggingface.onToken = onToken . chunkToText+          }+    case eRes of+      Left err -> pure $ Left $ llmError (T.pack err) Nothing Nothing+      Right r -> pure $ Right r     where       chunkToText :: Huggingface.ChatCompletionChunk -> Text       chunkToText Huggingface.ChatCompletionChunk {..} = do@@ -210,7 +222,7 @@           Just Huggingface.ChoiceChunk {..} ->             fromMaybe "" ((\Huggingface.Delta {..} -> deltaContent) delta) -toHuggingfaceMessages :: LLM.ChatMessage -> [Huggingface.Message]+toHuggingfaceMessages :: LLM.ChatHistory -> [Huggingface.Message] toHuggingfaceMessages msgs = map go (NE.toList msgs)   where     toRole :: LLM.Role -> Huggingface.Role@@ -225,7 +237,7 @@      go :: LLM.Message -> Huggingface.Message     go msg =-      Huggingface.defaultMessage+      Huggingface.defaultHugginfaceMessage         { Huggingface.role = toRole $ LLM.role msg         , Huggingface.content = Huggingface.TextContent (LLM.content msg)         }

@@ -43,12 +43,13 @@   , getProviderLink   , createChatCompletion   , defaultHuggingfaceChatCompletionRequest-  , defaultMessage+  , defaultHugginfaceMessage   , createChatCompletionStream   , defaultHuggingfaceStreamHandler   ) where  import Conduit+import Control.Monad (when) import Data.Aeson import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS@@ -59,6 +60,7 @@ import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import GHC.Generics+import qualified Langchain.LLM.Core as LLM import Network.HTTP.Conduit import Network.HTTP.Simple   ( getResponseBody@@ -156,7 +158,7 @@   parseJSON invalid = fail $ "Invalid tool choice: " ++ show invalid  -- | Provides details for a specific tool choice.-data SpecificToolChoice = SpecificToolChoice+newtype SpecificToolChoice = SpecificToolChoice   { specificToolChoiceFunction :: Value   -- ^ Function details   }@@ -174,7 +176,7 @@       <$> v .: "function"  -- | Options for streaming responses.-data StreamOptions = StreamOptions+newtype StreamOptions = StreamOptions   { includeUsage :: Bool   -- ^ Whether to include usage information   }@@ -209,7 +211,7 @@     _ -> fail $ "Unknown role: " ++ T.unpack t  -- | Image url object-data ImageUrl = ImageUrl+newtype ImageUrl = ImageUrl   { url :: String   }   deriving (Eq, Show, Generic)@@ -264,11 +266,11 @@   deriving (Eq, Show, Generic)  -- | Default message type-defaultMessage :: Message-defaultMessage =+defaultHugginfaceMessage :: Message+defaultHugginfaceMessage =   Message     { role = User-    , content = TextContent "What is the meaining of life?"+    , content = TextContent "What is the meaning of life?"     , name = Nothing     } @@ -285,7 +287,7 @@       <*> v .: "content"       <*> v .:? "name" -{- | $providers+{- | \$providers Supported providers and their API endpoints:  - Cerebras: @https://router.huggingface.co/cerebras/...@@ -360,7 +362,7 @@   HuggingfaceChatCompletionRequest     { provider = Cerebras     , timeout = Nothing-    , messages = [defaultMessage]+    , messages = [defaultHugginfaceMessage]     , model = "llama-3.3-70b"     , stream = False     , maxTokens = Nothing@@ -500,7 +502,7 @@       <*> v .: "time_info"  -- | Response for stream-data Delta = Delta+newtype Delta = Delta   { deltaContent :: Maybe Text   }   deriving (Eq, Show, Generic)@@ -603,8 +605,7 @@               setRequestSecure True $                 setRequestHeader "Content-Type" ["application/json"] $                   setRequestHeader "Authorization" ["Bearer " <> encodeUtf8 apiKey] $-                    setRequestBodyJSON r $-                      request_+                    setRequestBodyJSON r request_        response <- httpLbs req manager       let status = statusCode $ getResponseStatus response@@ -612,7 +613,13 @@         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)+        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.@@ -634,7 +641,10 @@  -- | Streaming function for huggingface createChatCompletionStream ::-  Text -> HuggingfaceChatCompletionRequest -> HuggingfaceStreamHandler -> IO (Either String ())+  Text ->+  HuggingfaceChatCompletionRequest ->+  HuggingfaceStreamHandler ->+  IO (Either String ()) createChatCompletionStream apiKey r HuggingfaceStreamHandler {..} = do   case getProviderLink (provider r) of     Nothing -> pure $ Left "Incompatible provider"@@ -645,8 +655,7 @@               setRequestMethod "POST" $                 setRequestSecure True $                   setRequestHeader "Content-Type" ["application/json"] $-                    setRequestBodyJSON r $-                      request_+                    setRequestBodyJSON r request_        manager <-         newManager@@ -666,21 +675,55 @@       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+          when+            (BS.isPrefixOf "data: " line)+            ( do+                do+                  let content = BS.drop 6 line -- Remove "data: " prefix+                  case decode (LBS.fromStrict content) of+                    Just chunk -> onToken chunk+                    Nothing -> do+                      -- Handle potential partial JSON by buffering+                      oldBuffer <- readIORef bufferRef+                      let newBuffer = oldBuffer <> content+                      writeIORef bufferRef newBuffer+                      -- Try to parse the combined buffer+                      case decode (LBS.fromStrict newBuffer) of+                        Just chunk -> do+                          onToken chunk+                          writeIORef bufferRef BS.empty -- Clear buffer after successful parse+                        Nothing -> return () -- Keep in buffer for next chunk+            )++instance LLM.MessageConvertible Message where+  -- to :: LLM.Message -> Message+  to msg =+    defaultHugginfaceMessage+      { role = toRole $ LLM.role msg+      , content = TextContent (LLM.content msg)+      }+    where+      toRole :: LLM.Role -> Role+      toRole r = case r of+        LLM.System -> System+        LLM.User -> User+        LLM.Assistant -> Assistant+        LLM.Tool -> Tool+        _ -> User++  -- from :: Message -> LLM.Message+  from msg =+    LLM.Message+      { LLM.role = toRole (role msg)+      , LLM.content = case content msg of+          TextContent txt -> txt+          _ -> ""+      , LLM.messageData = LLM.defaultMessageData+      }+    where+      toRole :: Role -> LLM.Role+      toRole r = case r of+        System -> LLM.System+        User -> LLM.User+        Assistant -> LLM.Assistant+        Tool -> LLM.Tool

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

@@ -1,7 +1,9 @@ {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  {- | Module      : Langchain.LLM.Ollama@@ -22,7 +24,7 @@  @ -- Create Ollama configuration-ollamaLLM = Ollama "llama3" [stdOutCallback]+ollamaLLM = Ollama "gemma3" [stdOutCallback]  -- Generate text response <- generate ollamaLLM "Explain Haskell monads" Nothing@@ -38,16 +40,23 @@ streamResult <- stream ollamaLLM messages streamHandler Nothing @ -}-module Langchain.LLM.Ollama (Ollama (..), OllamaParams(..), defaultOllamaParams) where+module Langchain.LLM.Ollama+  ( Ollama (..)+  , defaultOllama -import Data.Aeson-import Data.List.NonEmpty (NonEmpty)+    -- * Re-export+  , module Langchain.LLM.Core+  ) where+ import qualified Data.List.NonEmpty as NonEmpty+import Data.Maybe (fromMaybe) import qualified Data.Ollama.Chat as OllamaChat import qualified Data.Ollama.Common.Types as O-import qualified Data.Ollama.Generate as OllamaGenerate import Data.Text (Text)+import qualified Data.Text as T import Langchain.Callback (Callback, Event (..))+import Langchain.Error (llmError)+import qualified Langchain.Error as Error import Langchain.LLM.Core import qualified Langchain.Runnable.Core as Run @@ -72,37 +81,7 @@ 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).- Example instance usage:  @@@ -113,7 +92,8 @@ @ -} instance LLM Ollama where-  type LLMParams Ollama = OllamaParams+  type LLMParams Ollama = OllamaChat.ChatOps+  type LLMStreamTokenType Ollama = OllamaChat.ChatResponse    -- \| Generate text from a prompt   --  Returns Left on API errors, Right on success.@@ -121,33 +101,26 @@   --  Example:   --  >>> generate (Ollama "llama3.2" []) "Hello" Nothing   --  Right "Hello! How can I assist you today?"-  --   generate (Ollama model cbs) prompt mbOllamaParams = do     mapM_ (\cb -> cb LLMStart) cbs-    eRes <--      OllamaGenerate.generate-        OllamaGenerate.defaultGenerateOps-          { 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-          }+    let chatOps_ = fromMaybe OllamaChat.defaultChatOps mbOllamaParams+        msg = OllamaChat.userMessage prompt+        chatOps =+          chatOps_+            { OllamaChat.modelName = model+            , OllamaChat.messages = [msg]+            }++    eRes <- OllamaChat.chat chatOps Nothing     case eRes of       Left err -> do-        mapM_ (\cb -> cb (LLMError err)) cbs-        return $ Left (show err)-      Right res -> do+        mapM_ (\cb -> cb (LLMError $ show err)) cbs+        return $ Left (llmError (T.pack $ show err) Nothing Nothing)+      Right chatResponse -> do         mapM_ (\cb -> cb LLMEnd) cbs-        return $ Right (OllamaGenerate.response_ res)+        case OllamaChat.message chatResponse of+          Nothing -> pure $ Left (Error.fromString "Message not found in response")+          Just m -> pure $ Right $ OllamaChat.content m    -- \| Chat interaction with message history.   --  Uses Ollama's chat API for multi-turn conversations.@@ -156,31 +129,30 @@   --  >>> let msgs = UserMessage "Hi" :| [AssistantMessage "Hello!"]   --  >>> chat (Ollama "llama3" []) msgs Nothing   --  Right "How are you today?"-  --   chat (Ollama model cbs) messages mbOllamaParams = do     mapM_ (\cb -> cb LLMStart) cbs-    eRes <--      OllamaChat.chat-        OllamaChat.defaultChatOps-          { 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-          }+    let chatOps_ = fromMaybe OllamaChat.defaultChatOps mbOllamaParams+        chatOps =+          chatOps_+            { OllamaChat.modelName = model+            , OllamaChat.messages = NonEmpty.map to messages+            }+    eRes <- OllamaChat.chat chatOps Nothing     case eRes of       Left err -> do-        mapM_ (\cb -> cb (LLMError err)) cbs-        return $ Left (show err)+        mapM_ (\cb -> cb (LLMError $ show err)) cbs+        return $ Left (llmError (T.pack $ show err) Nothing Nothing)       Right res -> do         mapM_ (\cb -> cb LLMEnd) cbs-        return $ Right (chatRespToText res)-    where-      chatRespToText resp = maybe "" OllamaChat.content (OllamaChat.message resp)+        case OllamaChat.message res of+          Nothing ->+            return $+              Left $+                llmError+                  (T.pack $ "Message field not found: " <> show res)+                  Nothing+                  Nothing+          Just ollamaMsg -> return $ Right (from ollamaMsg)    -- \| Streaming response handling.   --  Processes tokens in real-time via StreamHandler.@@ -190,85 +162,97 @@   --  >>> stream (Ollama "llama3" []) messages handler Nothing   --  Token: H Token: i Complete   ---  stream (Ollama model_ cbs) messages StreamHandler {onToken, onComplete} mbOllamaParams = do-    mapM_ (\cb -> cb LLMStart) cbs-    eRes <--      OllamaChat.chat-        OllamaChat.defaultChatOps-          { 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-        mapM_ (\cb -> cb (LLMError err)) cbs-        return $ Left (show err)-      Right _ -> do-        mapM_ (\cb -> cb LLMEnd) cbs-        return $ Right ()-    where-      chatRespToText OllamaChat.ChatResponse {..} = maybe "" OllamaChat.content message--{- | Convert LangChain messages to Ollama format.-Current limitations:-- Ignores 'messageData' field-- No tool call support (see TODO)+  -- Note: Don't pass streamHandler in ChatOps's stream field. It will be overridden.+  stream+    (Ollama model_ cbs)+    messages+    StreamHandler {onToken, onComplete}+    mbOllamaParams = do+      let chatOps_ = fromMaybe OllamaChat.defaultChatOps mbOllamaParams+          chatOps =+            chatOps_+              { OllamaChat.modelName = model_+              , OllamaChat.messages = NonEmpty.map to messages+              , OllamaChat.stream =+                  Just+                    ( onToken+                    , pure ()+                    )+              }+      mapM_ (\cb -> cb LLMStart) cbs+      eRes <- OllamaChat.chat chatOps Nothing+      case eRes of+        Left err -> do+          mapM_ (\cb -> cb (LLMError $ show err)) cbs+          return $ Left (llmError (T.pack $ show err) Nothing Nothing)+        Right _ -> do+          onComplete+          mapM_ (\cb -> cb LLMEnd) cbs+          return $ Right () -Example conversion:->>> let msg = Message System "You are an assistant" defaultMessageData->>> toOllamaMessages (msg :| [])-NonEmpty [OllamaChat.Message System "You are an assistant" Nothing Nothing]--}-toOllamaMessages :: NonEmpty Message -> NonEmpty OllamaChat.Message-toOllamaMessages = NonEmpty.map $ \Message {..} ->-  OllamaChat.Message (toOllamaRole role) content Nothing Nothing-  where-    toOllamaRole User = OllamaChat.User-    toOllamaRole System = OllamaChat.System-    toOllamaRole Assistant = OllamaChat.Assistant-    toOllamaRole Tool = OllamaChat.Tool-    toOllamaRole _ = OllamaChat.User -- Ollama only supports above 4 Roles, others will be defaulted to user+toOllamaRole :: Role -> OllamaChat.Role+toOllamaRole User = OllamaChat.User+toOllamaRole System = OllamaChat.System+toOllamaRole Assistant = OllamaChat.Assistant+toOllamaRole Tool = OllamaChat.Tool+toOllamaRole _ = OllamaChat.User -- Ollama only supports above 4 Roles, others will be defaulted to user -instance Run.Runnable Ollama where-  type RunnableInput Ollama = (ChatMessage, Maybe OllamaParams)-  type RunnableOutput Ollama = Text+fromOllamaRole :: OllamaChat.Role -> Role+fromOllamaRole OllamaChat.User = User+fromOllamaRole OllamaChat.System = System+fromOllamaRole OllamaChat.Assistant = Assistant+fromOllamaRole OllamaChat.Tool = Tool -  invoke = uncurry . chat +instance MessageConvertible OllamaChat.Message where+  to Message {..} =+    OllamaChat.Message+      (toOllamaRole role)+      content+      (messageImages messageData)+      (fmap toOllamaToolCall <$> toolCalls messageData)+      (thinking messageData)+    where+      toOllamaToolCall :: ToolCall -> O.ToolCall+      toOllamaToolCall ToolCall {..} =+        O.ToolCall+          { O.outputFunction =+              O.OutputFunction+                { O.outputFunctionName = toolFunctionName toolCallFunction+                , O.arguments = toolFunctionArguments toolCallFunction+                }+          } --- | 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-  }+  from (OllamaChat.Message role' content' imgs tools think) =+    Message+      { role = fromOllamaRole role'+      , content = content'+      , messageData =+          MessageData+            { messageImages = imgs+            , toolCalls = fmap toToolCall <$> tools+            , thinking = think+            , name = Nothing+            }+      }+    where+      toToolCall :: O.ToolCall -> ToolCall+      toToolCall O.ToolCall {..} =+        ToolCall+          { toolCallId = ""+          , toolCallType = "function"+          , toolCallFunction =+              ToolFunction+                { toolFunctionName = O.outputFunctionName outputFunction+                , toolFunctionArguments = O.arguments outputFunction+                }+          } -{- $examples-Test case patterns:-1. Basic generation-   >>> generate (Ollama "test-model" []) "Hello" Nothing-   Right "Mock response"+instance Run.Runnable Ollama where+  type RunnableInput Ollama = (ChatHistory, Maybe OllamaChat.ChatOps)+  type RunnableOutput Ollama = Message -2. Error handling-   >>> generate (Ollama "invalid-model" []) "Test" Nothing-   Left "API request failed"+  invoke = uncurry . chat -3. Streaming interaction-   >>> let handler = StreamHandler print (pure ())-   >>> stream (Ollama "llama3" []) (UserMessage "Hi" :| []) handler Nothing-   Right ()--}+-- | Default values for Ollama+defaultOllama :: Ollama+defaultOllama = Ollama "llama3.2" []

@@ -1,4 +1,4 @@-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-}@@ -28,8 +28,8 @@ main = do   let openAI = OpenAI         { apiKey = "your-api-key"-        , openAIModelName = "gpt-3.5-turbo"         , callbacks = []+        , baseUrl = Nothing         }   result <- LLM.generate openAI "Tell me a joke" Nothing   case result of@@ -38,22 +38,25 @@ @ -} module Langchain.LLM.OpenAI-  ( -    -- * Types+  ( -- * Types     OpenAI (..)-  , OpenAIParams (..)+     -- * Default functions-  , defaultOpenAIParams+  , defaultOpenAI++    -- * Re-export+  , module Langchain.LLM.Core   ) where -import qualified Data.List.NonEmpty as NE-import Data.Map (Map)-import Data.Maybe (fromMaybe, listToMaybe)+import Data.Maybe (fromMaybe) import Data.Text (Text) import Langchain.Callback (Callback)+import Langchain.LLM.Core import qualified Langchain.LLM.Core as LLM-import qualified Langchain.LLM.Internal.OpenAI as OpenAI+import Langchain.LLM.OpenAICompatible (OpenAICompatible)+import qualified Langchain.LLM.OpenAICompatible as OpenAICompatible import qualified Langchain.Runnable.Core as Run+import qualified OpenAI.V1.Chat.Completions as OpenAIV1  {- | Configuration for OpenAI's language models. @@ -63,276 +66,48 @@ 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.+  , baseUrl :: Maybe String+  -- ^ Base url; default "https://api.openai.com"   }  -- | Not including API key to avoid accidental leak instance Show OpenAI where-  show OpenAI {..} = "OpenAI " ++ show openAIModelName+  show _ = "OpenAI" +toOpenAI :: OpenAI -> OpenAICompatible+toOpenAI OpenAI {..} =+  OpenAICompatible.OpenAICompatible+    { apiKey = apiKey+    , callbacks = callbacks+    , baseUrl =+        Just $+          fromMaybe+            "https://api.openai.com"+            baseUrl+    , providerName = "OpenAI"+    }+ {- | Implementation of the 'LLM' typeclass for OpenAI models.  This instance provides methods for generating text, handling chat interactions, and streaming responses using OpenAI's API. -} instance LLM.LLM OpenAI where-  type LLMParams OpenAI = 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+  type LLMParams OpenAI = OpenAIV1.CreateChatCompletion+  type LLMStreamTokenType OpenAI = OpenAIV1.ChatCompletionChunk -    go :: LLM.Message -> OpenAI.Message-    go msg =-      OpenAI.defaultMessage-        { OpenAI.role = toRole $ LLM.role msg-        , OpenAI.content = Just $ OpenAI.StringContent (LLM.content msg)-        }+  generate = LLM.generate . toOpenAI+  chat = LLM.chat . toOpenAI+  stream = LLM.stream . toOpenAI  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-  }+  type RunnableInput OpenAI = (ChatHistory, Maybe OpenAIV1.CreateChatCompletion)+  type RunnableOutput OpenAI = LLM.Message --- | 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-    }+  invoke = uncurry . chat -{--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."--}+-- | Default values for OpenAI+defaultOpenAI :: OpenAI+defaultOpenAI = OpenAI "your-api-key" [] Nothing

@@ -0,0 +1,403 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++{- |+Module      : Langchain.LLM.OpenAICompatible+Description : Generic OpenAI-compatible API integration for LangChain Haskell+Copyright   : (c) 2025 Tushar Adhatrao+License     : MIT+Maintainer  : Tushar Adhatrao <tusharadhatrao@gmail.com>+Stability   : experimental++This module provides a generic 'OpenAICompatible' data type and+implements the 'LLM' typeclass for interacting with any service that provides+an OpenAI-compatible API interface.+-}+module Langchain.LLM.OpenAICompatible+  ( OpenAICompatible (..)+  , mkOpenRouter+  , module Langchain.LLM.Core+  ) where++import Control.Exception (SomeException, try)+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.KeyMap as KM+import qualified Data.ByteString.Lazy.Char8 as BSL+import qualified Data.List.NonEmpty as NE+import Data.Maybe (fromMaybe, listToMaybe)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Vector as V+import Langchain.Callback+import qualified Langchain.Error as Error+import Langchain.LLM.Core+import qualified Langchain.LLM.Core as LLM+import qualified Langchain.Runnable.Core as LLM+import OpenAI.V1+import OpenAI.V1.Chat.Completions+import qualified OpenAI.V1.Chat.Completions as OpenAIV1+import qualified OpenAI.V1.ToolCall as OpenAIV1++-- | Generic OpenAICompatible implementation for any service with an OpenAI-compatible API+data OpenAICompatible = OpenAICompatible+  { apiKey :: T.Text+  -- ^ The API key for authenticating.+  , callbacks :: [Callback]+  -- ^ A list of callbacks for handling events during LLM operations+  , baseUrl :: Maybe String+  -- ^ Base URL for the service. Default "https://api.openai.com"+  , providerName :: T.Text+  -- ^ The provider or service name+  }++instance Show OpenAICompatible where+  show OpenAICompatible {..} = show providerName++-- | Helper function to extract text from OpenAI Message T.Text+messageToText :: OpenAIV1.Message T.Text -> T.Text+messageToText (OpenAIV1.User {OpenAIV1.content = c}) = c+messageToText (OpenAIV1.System {OpenAIV1.content = c}) = c+messageToText (OpenAIV1.Assistant {OpenAIV1.assistant_content = ac}) = fromMaybe "" ac+messageToText (OpenAIV1.Tool {OpenAIV1.content = c}) = c++-- | Helper function to extract text from Vector Content+extractTextFromContent :: V.Vector OpenAIV1.Content -> T.Text+extractTextFromContent contents =+  fromMaybe "" $ listToMaybe $ V.toList $ V.mapMaybe getTextContent contents+  where+    getTextContent :: OpenAIV1.Content -> Maybe T.Text+    getTextContent (OpenAIV1.Text txt) = Just txt+    getTextContent _ = Nothing++-- | Helper function to create content list with text+makeContentList :: T.Text -> Maybe [T.Text] -> V.Vector OpenAIV1.Content+makeContentList text mbImageData = do+  let res = V.fromList [OpenAIV1.Text text]+  res <> case mbImageData of+    Just images ->+      V.fromList+        ( map+            ( OpenAIV1.Image_URL+                . (\urlText -> OpenAIV1.ImageURL {url = urlText, detail = Nothing})+            )+            images+        )+    Nothing -> V.empty++toOpenAIToolCall :: [ToolCall] -> V.Vector OpenAIV1.ToolCall+toOpenAIToolCall = V.fromList . map go+  where+    go :: ToolCall -> OpenAIV1.ToolCall+    go = \case+      ToolCall {toolCallId, toolCallFunction = ToolFunction {toolFunctionName, toolFunctionArguments}} ->+        OpenAIV1.ToolCall_Function+          { OpenAIV1.id = toolCallId+          , OpenAIV1.function =+              OpenAIV1.Function+                { OpenAIV1.name = toolFunctionName+                , OpenAIV1.arguments = T.decodeUtf8 $ BSL.toStrict $ Aeson.encode toolFunctionArguments+                }+          }++fromOpenAIToolCall :: OpenAIV1.ToolCall -> ToolCall+fromOpenAIToolCall = \case+  OpenAIV1.ToolCall_Function+    { OpenAIV1.id = tcId+    , OpenAIV1.function =+      OpenAIV1.Function+        { OpenAIV1.name = fnName+        , OpenAIV1.arguments = fnArgs+        }+    } ->+      let argsVal = Aeson.decode (BSL.fromStrict $ T.encodeUtf8 fnArgs) :: Maybe Aeson.Value+          argsMap = case argsVal of+            Just (Aeson.Object o) -> KM.toMapText o+            _ -> mempty+       in ToolCall+            { toolCallId = tcId+            , toolCallType = "function"+            , toolCallFunction =+                ToolFunction+                  { toolFunctionName = fnName+                  , toolFunctionArguments = argsMap+                  }+            }++getToolId :: [ToolCall] -> T.Text+getToolId toolCalls = case toolCalls of+  (ToolCall {toolCallId} : _) -> toolCallId+  [] -> ""++getImageDataIfExists :: V.Vector OpenAIV1.Content -> Maybe [T.Text]+getImageDataIfExists contents =+  let images = V.toList $ V.mapMaybe getImageContent contents+   in if null images then Nothing else Just images+  where+    getImageContent :: OpenAIV1.Content -> Maybe T.Text+    getImageContent (OpenAIV1.Image_URL imgUrl) = Just $ url imgUrl+    getImageContent _ = Nothing++{- | MessageConvertible instance for OpenAIV1.Message (V.Vector OpenAIV1.Content)+This is used for request messages+-}+instance LLM.MessageConvertible (OpenAIV1.Message (V.Vector OpenAIV1.Content)) where+  -- \| Convert LLM.Message to OpenAIV1.Message (V.Vector OpenAIV1.Content)+  to :: LLM.Message -> OpenAIV1.Message (V.Vector OpenAIV1.Content)+  to msg =+    let imagesData = LLM.messageImages $ LLM.messageData msg+        contentVec = makeContentList (LLM.content msg) imagesData+        msgName = LLM.name $ LLM.messageData msg+     in case LLM.role msg of+          LLM.User ->+            OpenAIV1.User+              { OpenAIV1.content = contentVec+              , OpenAIV1.name = msgName+              }+          LLM.System ->+            OpenAIV1.System+              { OpenAIV1.content = contentVec+              , OpenAIV1.name = msgName+              }+          LLM.Assistant ->+            OpenAIV1.Assistant+              { OpenAIV1.assistant_content = Just contentVec+              , OpenAIV1.name = msgName+              , OpenAIV1.refusal = Nothing+              , OpenAIV1.assistant_audio = Nothing+              , OpenAIV1.tool_calls = fmap toOpenAIToolCall <$> toolCalls $ messageData msg+              }+          LLM.Tool ->+            OpenAIV1.Tool+              { OpenAIV1.content = contentVec+              , OpenAIV1.tool_call_id = fromMaybe "" $ fmap getToolId <$> toolCalls $ messageData msg+              }+          -- Fallback to User for unsupported roles (Developer, Function)+          _ ->+            OpenAIV1.User+              { OpenAIV1.content = contentVec+              , OpenAIV1.name = msgName+              }++  -- \| Convert OpenAIV1.Message (V.Vector OpenAIV1.Content) to LLM.Message+  from :: OpenAIV1.Message (V.Vector OpenAIV1.Content) -> LLM.Message+  from msg = case msg of+    OpenAIV1.User {OpenAIV1.content = c, OpenAIV1.name = n} ->+      LLM.Message+        { LLM.role = LLM.User+        , LLM.content = extractTextFromContent c+        , LLM.messageData =+            LLM.MessageData+              { LLM.name = n+              , LLM.toolCalls = Nothing+              , LLM.messageImages = getImageDataIfExists c+              , LLM.thinking = Nothing+              }+        }+    OpenAIV1.System {OpenAIV1.content = c, OpenAIV1.name = n} ->+      LLM.Message+        { LLM.role = LLM.System+        , LLM.content = extractTextFromContent c+        , LLM.messageData =+            LLM.MessageData+              { LLM.name = n+              , LLM.toolCalls = Nothing+              , LLM.messageImages = getImageDataIfExists c+              , LLM.thinking = Nothing+              }+        }+    OpenAIV1.Assistant+      { OpenAIV1.assistant_content = ac+      , OpenAIV1.name = n+      , OpenAIV1.tool_calls = mbToolVector+      } ->+        LLM.Message+          { LLM.role = LLM.Assistant+          , LLM.content = maybe "" extractTextFromContent ac+          , LLM.messageData =+              LLM.MessageData+                { LLM.name = n+                , LLM.toolCalls = fmap (V.toList . V.map fromOpenAIToolCall) mbToolVector+                , LLM.messageImages = getImageDataIfExists =<< ac+                , LLM.thinking = Nothing+                }+          }+    OpenAIV1.Tool {OpenAIV1.content = c, OpenAIV1.tool_call_id = toolCallid} ->+      LLM.Message+        { LLM.role = LLM.Tool+        , LLM.content = extractTextFromContent c+        , LLM.messageData =+            LLM.MessageData+              { LLM.name = Nothing+              , LLM.toolCalls =+                  Just+                    [ ToolCall+                        { toolCallId = toolCallid+                        , toolCallType = "function"+                        , toolCallFunction =+                            ToolFunction+                              { toolFunctionName = ""+                              , toolFunctionArguments = mempty+                              }+                        }+                    ]+              , LLM.messageImages = getImageDataIfExists c+              , LLM.thinking = Nothing+              }+        }++instance LLM.MessageConvertible (OpenAIV1.Message T.Text) where+  to :: LLM.Message -> OpenAIV1.Message T.Text+  to _ = error "Conversion to OpenAIV1.Message T.Text not implemented."++  -- \| Convert OpenAIV1.Message T.Text to LLM.Message+  from :: OpenAIV1.Message T.Text -> LLM.Message+  from msg = case msg of+    OpenAIV1.User {OpenAIV1.content = c, OpenAIV1.name = n} ->+      LLM.Message+        { LLM.role = LLM.User+        , LLM.content = c+        , LLM.messageData =+            LLM.MessageData+              { LLM.name = n+              , LLM.toolCalls = Nothing+              , LLM.messageImages = Nothing+              , LLM.thinking = Nothing+              }+        }+    OpenAIV1.System {OpenAIV1.content = c, OpenAIV1.name = n} ->+      LLM.Message+        { LLM.role = LLM.System+        , LLM.content = c+        , LLM.messageData =+            LLM.MessageData+              { LLM.name = n+              , LLM.toolCalls = Nothing+              , LLM.messageImages = Nothing+              , LLM.thinking = Nothing+              }+        }+    OpenAIV1.Assistant+      { OpenAIV1.assistant_content = ac+      , OpenAIV1.name = n+      , OpenAIV1.tool_calls = mbToolVector+      } ->+        LLM.Message+          { LLM.role = LLM.Assistant+          , LLM.content = fromMaybe "" ac+          , LLM.messageData =+              LLM.MessageData+                { LLM.name = n+                , LLM.toolCalls = fmap (V.toList . V.map fromOpenAIToolCall) mbToolVector+                , LLM.messageImages = Nothing+                , LLM.thinking = Nothing+                }+          }+    OpenAIV1.Tool {OpenAIV1.content = c, OpenAIV1.tool_call_id = toolCallid} ->+      LLM.Message+        { LLM.role = LLM.Tool+        , LLM.content = c+        , LLM.messageData =+            LLM.MessageData+              { LLM.name = Nothing+              , LLM.toolCalls =+                  Just+                    [ ToolCall+                        { toolCallId = toolCallid+                        , toolCallType = "function"+                        , toolCallFunction =+                            ToolFunction+                              { toolFunctionName = ""+                              , toolFunctionArguments = mempty+                              }+                        }+                    ]+              , LLM.messageImages = Nothing+              , LLM.thinking = Nothing+              }+        }++-- | Helper function to convert LLM.Message to OpenAI Message (using MessageConvertible)+toOpenAIMsg :: LLM.Message -> OpenAIV1.Message (V.Vector OpenAIV1.Content)+toOpenAIMsg = LLM.to++-- | Helper function to convert OpenAI Message to LLM.Message (using MessageConvertible)+fromOpenAIMsg :: OpenAIV1.Message T.Text -> LLM.Message+fromOpenAIMsg = LLM.from++instance LLM.LLM OpenAICompatible where+  type LLMParams OpenAICompatible = OpenAIV1.CreateChatCompletion+  type LLMStreamTokenType OpenAICompatible = OpenAIV1.ChatCompletionChunk++  generate OpenAICompatible {..} prompt mbLLMParams = do+    clientEnv <- getClientEnv $ maybe "https://api.openai.com" T.pack baseUrl+    let Methods {createChatCompletion} = makeMethods clientEnv apiKey Nothing Nothing+    let openaiParams = fromMaybe _CreateChatCompletion mbLLMParams++    eRes <-+      try $+        createChatCompletion+          openaiParams+            { OpenAIV1.messages =+                V.fromList+                  [ OpenAIV1.User+                      { OpenAIV1.content = V.fromList [OpenAIV1.Text prompt]+                      , name = Nothing+                      }+                  ]+            }+    case eRes of+      Left err -> pure $ Left $ Error.fromString $ show (err :: SomeException)+      Right (ChatCompletionObject {choices}) -> do+        let Choice {message} = V.head choices+        pure (Right $ messageToText message)++  chat OpenAICompatible {..} chatHistory mbLLMParams = do+    clientEnv <- getClientEnv $ maybe "https://api.openai.com" T.pack baseUrl+    let Methods {createChatCompletion} = makeMethods clientEnv apiKey Nothing Nothing+    let openaiParams = fromMaybe _CreateChatCompletion mbLLMParams+    eRes <-+      try $+        createChatCompletion+          openaiParams {OpenAIV1.messages = V.fromList $ map toOpenAIMsg (NE.toList chatHistory)}+    case eRes of+      Left err -> pure $ Left $ Error.fromString $ show (err :: SomeException)+      Right (ChatCompletionObject {choices}) -> do+        let Choice {message} = V.head choices+        pure (Right $ fromOpenAIMsg message)++  stream OpenAICompatible {..} chatHistory streamHandler mbLLMParams = do+    let onEvent (Left _) = pure () -- ignore for now+        onEvent (Right chunk) = onToken streamHandler chunk++    clientEnv <- getClientEnv $ maybe "https://api.openai.com" T.pack baseUrl+    let Methods {createChatCompletionStreamTyped} = makeMethods clientEnv apiKey Nothing Nothing+    let openaiParams = fromMaybe _CreateChatCompletion mbLLMParams++    let req_ = openaiParams {OpenAIV1.messages = V.fromList $ map toOpenAIMsg (NE.toList chatHistory)}+    _ <- createChatCompletionStreamTyped req_ onEvent+    pure $ Right ()++{- | Create an OpenRouter instance+OpenRouter provides access to multiple model providers through a single API+Model name should be in the format "provider/model" (e.g., "anthropic/claude-3-opus")+-}+mkOpenRouter :: [Callback] -> Maybe String -> T.Text -> OpenAICompatible+mkOpenRouter callbacks' baseUrl' apiKey' =+  OpenAICompatible+    { apiKey = apiKey' -- OpenRouter requires an API key+    , callbacks = callbacks'+    , baseUrl = Just $ fromMaybe "https://openrouter.ai/api" baseUrl'+    , providerName = "OpenRouter"+    }++instance LLM.Runnable OpenAICompatible where+  type RunnableInput OpenAICompatible = (ChatHistory, Maybe OpenAIV1.CreateChatCompletion)+  type RunnableOutput OpenAICompatible = LLM.Message++  invoke = uncurry . chat

@@ -38,9 +38,16 @@   , initialChatMessage   ) where +import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.List.NonEmpty as NE import Data.Text (Text)-import Langchain.LLM.Core (ChatMessage, Message (..), Role (..), defaultMessageData)+import Langchain.Error (LangchainResult)+import Langchain.LLM.Core+  ( ChatHistory+  , Message (..)+  , Role (..)+  , defaultMessageData+  ) import Langchain.Runnable.Core  {- | Base typeclass for memory implementations@@ -54,22 +61,37 @@   addUserMessage = ... @ -}-class BaseMemory m where+class BaseMemory mem where   -- | Retrieve current chat history-  messages :: m -> IO (Either String ChatMessage)+  messages :: mem -> IO (LangchainResult ChatHistory)    -- | Add user message to history-  addUserMessage :: m -> Text -> IO (Either String m)+  addUserMessage :: mem -> Text -> IO (LangchainResult mem)    -- | Add AI response to history-  addAiMessage :: m -> Text -> IO (Either String m)+  addAiMessage :: mem -> Text -> IO (LangchainResult mem)    -- | Add generic message to history-  addMessage :: m -> Message -> IO (Either String m)+  addMessage :: mem -> Message -> IO (LangchainResult mem)    -- | Reset memory to initial state-  clear :: m -> IO (Either String m)+  clear :: mem -> IO (LangchainResult mem) +  messagesM :: MonadIO m => mem -> m (LangchainResult ChatHistory)+  messagesM = liftIO . messages++  addUserMessageM :: MonadIO m => mem -> Text -> m (LangchainResult mem)+  addUserMessageM mem msg = liftIO $ addUserMessage mem msg++  addAiMessageM :: MonadIO m => mem -> Text -> m (LangchainResult mem)+  addAiMessageM mem msg = liftIO $ addAiMessage mem msg++  addMessageM :: MonadIO m => mem -> Message -> m (LangchainResult mem)+  addMessageM mem msg = liftIO $ addMessage mem msg++  clearM :: MonadIO m => mem -> m (LangchainResult mem)+  clearM mem = liftIO $ clear mem+ {- | Sliding window memory implementation. Stores chat history with maximum size limit. @@ -83,10 +105,11 @@ -} 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 +  {- ^ Maximum number of messages to retain+  ^ It is user's responsibility to make sure the number is > 0.+  -}+  , windowBufferMessages :: ChatHistory+  -- ^ Current message buffer   }   deriving (Show, Eq) @@ -97,7 +120,6 @@   --   --  >>> messages (WindowBufferMemory 5 initialMessages)   --  Right initialMessages-  --   messages WindowBufferMemory {..} = pure $ Right windowBufferMessages    -- \| Add message with window trimming@@ -110,24 +132,25 @@   --   --  >>> addMessage mem msg3   --  Right (WindowBufferMemory {windowBufferMessages = [msg2, msg3]})-  ---  addMessage winBuffMem@WindowBufferMemory{..} newMsg = do+  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 }+      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)+          go (m : ms)             | isSystem m = m : go ms             | otherwise = ms @@ -137,7 +160,6 @@   --   --  >>> addUserMessage mem "Hello"   --  Right (WindowBufferMemory { ... })-  --   addUserMessage winBuffMem uMsg =     addMessage winBuffMem (Message User uMsg defaultMessageData) @@ -147,7 +169,6 @@   --   --  >>> addAiMessage mem "Response"   --  Right (WindowBufferMemory { ... })-  --   addAiMessage winBuffMem uMsg =     addMessage winBuffMem (Message Assistant uMsg defaultMessageData) @@ -157,13 +178,13 @@   --   --  >>> clear mem   --  Right (WindowBufferMemory { windowBufferMessages = [systemMsg] })-  --   clear winBuffMem =     pure $       Right $         winBuffMem           { windowBufferMessages =-              NE.singleton $ Message System "You are an AI model" defaultMessageData+              NE.singleton $+                Message System "You are an AI model" defaultMessageData           }  {- | Trim chat history to last n messages@@ -173,8 +194,10 @@ >>> trimChatMessage 2 msgs [msg2, msg3] -}-trimChatMessage :: Int -> ChatMessage -> ChatMessage-trimChatMessage n msgs = NE.fromList $ drop (max 0 (NE.length msgs - n)) (NE.toList msgs)+trimChatMessage :: Int -> ChatHistory -> ChatHistory+trimChatMessage n msgs =+  NE.fromList $+    drop (max 0 (NE.length msgs - n)) (NE.toList msgs)  {- | Add and maintain window size Example:@@ -183,7 +206,7 @@ >>> addAndTrim 2 msg2 msgs [msg1, msg2] -}-addAndTrim :: Int -> Message -> ChatMessage -> ChatMessage+addAndTrim :: Int -> Message -> ChatHistory -> ChatHistory addAndTrim n msg msgs = trimChatMessage n (msgs <> NE.singleton msg)  {- | Create initial chat history@@ -192,8 +215,10 @@ >>> initialChatMessage "You are Qwen" [Message System "You are Qwen"] -}-initialChatMessage :: Text -> ChatMessage-initialChatMessage systemPrompt = NE.singleton $ Message System systemPrompt defaultMessageData+initialChatMessage :: Text -> ChatHistory+initialChatMessage systemPrompt =+  NE.singleton $+    Message System systemPrompt defaultMessageData  instance Runnable WindowBufferMemory where   type RunnableInput WindowBufferMemory = Text@@ -205,8 +230,7 @@   --   --  >>> invoke memory "Hello"   --  Right (WindowBufferMemory { ... })-  ---  invoke memory input = addUserMessage memory input+  invoke = addUserMessage  {- $examples Test case patterns:

@@ -14,11 +14,20 @@ 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+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.Error (llmError)+import Langchain.LLM.Core+  ( ChatHistory+  , Message (..)+  , Role (..)+  , defaultMessageData+  ) import Langchain.Memory.Core import Langchain.Runnable.Core (Runnable (..)) @@ -26,7 +35,7 @@ data TokenBufferMemory = TokenBufferMemory   { maxTokens :: Int   -- ^ Max number of tokens. 4 characters = 1 Token-  , tokenBufferMessages :: ChatMessage+  , tokenBufferMessages :: ChatHistory   -- ^ Chat history (Nonempty List of Message)   }   deriving (Eq, Show)@@ -38,32 +47,62 @@ countTokens = sum . map go   where     go :: Message -> Int-    go (Message _ content _) = ceiling @Double (fromIntegral (T.length content) / 4.0)+    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+        currentMsgsTokenCount = countTokens $ NE.toList tokenBufferMessages+    if newMsgTokenCount > maxTokens+      then+        pure (Left (llmError "New message is exceeding limit" Nothing Nothing))+      else+        if newMsgTokenCount + currentMsgsTokenCount <= maxTokens+          then+            pure+              ( Right $+                  t+                    { tokenBufferMessages =+                        tokenBufferMessages <> NE.fromList [newMsg]+                    }+              )+          else+            trimNonSystemMsgs+              (NE.toList tokenBufferMessages)+              newMsgTokenCount     where       trimNonSystemMsgs msgs newMsgTokenCount = do         let trimmedMsgs = removeOldestNonSystem msgs-        if trimmedMsgs == msgs 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-      +        if trimmedMsgs == msgs -- If no more non sys msg left+          then+            pure+              ( Left $+                  llmError+                    ( "Cannot add new message since system"+                        <> " message and new message exceeds limit"+                    )+                    Nothing+                    Nothing+              )+          else+            if countTokens trimmedMsgs + newMsgTokenCount <= maxTokens+              then+                pure+                  ( Right $+                      t+                        { tokenBufferMessages =+                            NE.fromList $ trimmedMsgs <> [newMsg]+                        }+                  )+              else trimNonSystemMsgs trimmedMsgs newMsgTokenCount+       removeOldestNonSystem = go         where-         go [] = []-         go (m:ms)+          go [] = []+          go (m : ms)             | isSystem m = m : go ms             | otherwise = ms @@ -80,11 +119,12 @@       Right $         tokBuffMem           { tokenBufferMessages =-              NE.singleton $ Message System "You are an AI model" defaultMessageData+              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+  invoke = addUserMessage

@@ -35,14 +35,16 @@ import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Data.Text.Internal.Search (indices)+import Langchain.Error (LangchainResult, parsingError)  {- | Typeclass for parsing output from language models into specific types. Instances of this class define how to convert a 'Text' output into a value of type 'a'. -} class OutputParser a where-  -- | Parse the given text into a value of type 'a'.-  -- Returns 'Left' with an error message if parsing fails, or 'Right' with the parsed value.-  parse :: Text -> Either String a+  {- | Parse the given text into a value of type 'a'.+  Returns 'Left' with an error message if parsing fails, or 'Right' with the parsed value.+  -}+  parse :: Text -> LangchainResult a  -- | Represents a list of text items separated by commas. newtype CommaSeparatedList = CommaSeparatedList [Text]@@ -74,15 +76,15 @@   -- @   parse txt = do     let txt' = T.strip $ T.toLower txt-    if length (indices "true" txt') > 0+    if not (null $ indices "true" txt')       then         Right True       else-        if length (indices "false" txt') > 0+        if not (null $ indices "false" txt')           then             Right False           else-            Left "Invalid boolean value"+            Left $ parsingError "Invalid boolean value" (Just "Bool") (Just txt)  instance OutputParser CommaSeparatedList where   -- \| Parse a comma-separated list from the text.@@ -135,7 +137,8 @@ instance FromJSON a => OutputParser (JSONOutputStructure a) where   parse txt =     case eitherDecode (fromStrict $ encodeUtf8 txt) of-      Left err -> Left $ "JSON parsing error: " ++ err+      Left err ->+        Left $ parsingError ("JSON parsing error: " <> T.pack err) (Just "JSONOutputStructure") (Just txt)       Right val -> Right val  -- | Represents a list of text items separated by numbered prefixes, like "1. First item".@@ -169,10 +172,11 @@   parse txt =     let s = trim (T.unpack txt)      in case dropUntilAndConsumeBoundary s of-          Nothing -> Left "No valid numbered items found"+          Nothing -> Left $ parsingError "No valid numbered items found" (Just "NumberSeparatedList") (Just txt)           Just rest ->             -- Parse the rest into items and wrap them in our newtype.-            Right . NumberSeparatedList . map (T.pack . trim) $ parseItems rest+            Right . NumberSeparatedList . map (T.pack . trim) $+              parseItems rest  {- | Drops noise until we find a valid boundary marker (number with dot) and then consumes the marker.@@ -187,7 +191,7 @@ Returns the index and length of the marker. -} findBoundary :: String -> Maybe (Int, Int)-findBoundary s = go 0 s+findBoundary = go 0   where     go _ [] = Nothing     go i xs@(_ : rest) =@@ -211,7 +215,12 @@                 (c : rest3)                   | c == '.' ->                       let (spaces2, _) = span isSpace rest3-                       in Just (length digits + length spaces + 1 + length spaces2)+                       in Just+                            ( length digits+                                + length spaces+                                + 1+                                + length spaces2+                            )                 _ -> Nothing  -- | Recursively splits the string into items using the boundary markers.

@@ -40,6 +40,7 @@ import qualified Data.Map.Strict as HM import Data.Text (Text) import qualified Data.Text as T+import Langchain.Error (LangchainResult, validationError) import Langchain.Runnable.Core (Runnable (..))  -- TODO: Add Mechanism for custom example selector@@ -75,7 +76,7 @@ -- Result: Left "Missing variable: place" @ -}-renderPrompt :: PromptTemplate -> HM.Map Text Text -> Either String Text+renderPrompt :: PromptTemplate -> HM.Map Text Text -> LangchainResult Text renderPrompt (PromptTemplate template) vars = interpolate vars template  {- | Represents a few-shot prompt template with examples.@@ -118,12 +119,12 @@ -- Result: Right "Examples of {type}:\nInput: Hello\nOutput: Bonjour\n\nInput: Goodbye\nOutput: Au revoir\nNow translate: {query}" @ -}-renderFewShotPrompt :: FewShotPromptTemplate -> Either String Text+renderFewShotPrompt :: FewShotPromptTemplate -> LangchainResult Text renderFewShotPrompt FewShotPromptTemplate {..} = do   -- Format each example using the example template   formattedExamples <-     mapM-      (\ex -> interpolate ex fsExampleTemplate)+      (`interpolate` fsExampleTemplate)       fsExamples   -- Join the formatted examples with the separator   let examplesText = T.intercalate fsExampleSeparator formattedExamples@@ -133,23 +134,23 @@ {- | Interpolate variables into a template string. Placeholders are of the form {key}, where key is a sequence of alphanumeric characters and underscores. -}-interpolate :: HM.Map Text Text -> Text -> Either String Text-interpolate vars template = go template+interpolate :: HM.Map Text Text -> Text -> LangchainResult Text+interpolate vars = go   where-    go :: Text -> Either String Text+    go :: Text -> LangchainResult Text     go t =       case T.breakOn "{" t of         (before, after) | T.null after -> Right before         (before, after') ->           case T.breakOn "}" (T.drop 1 after') of-            (_, after'') | T.null after'' -> Left "Unclosed brace"+            (_, after'') | T.null after'' -> Left $ validationError "Unclosed brace" Nothing Nothing             (key, after''') ->               let key' = T.strip key                in case HM.lookup key' vars of                     Just val -> do                       rest <- go (T.drop 1 after''')                       return $ before <> val <> rest-                    Nothing -> Left $ "Missing variable: " <> T.unpack key'+                    Nothing -> Left $ validationError ("Missing variable: " <> key') (Just key') Nothing  instance Runnable PromptTemplate where   type RunnableInput PromptTemplate = HM.Map Text Text

@@ -35,12 +35,13 @@   , VectorStoreRetriever (..)   ) where +import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Text (Text) import Langchain.DocumentLoader.Core (Document)+import Langchain.Error (LangchainResult) import Langchain.Runnable.Core import Langchain.VectorStore.Core -import Data.Text (Text)- {- | Typeclass for document retrieval systems Implementations should return documents relevant to a given query. @@ -56,14 +57,18 @@ @ -} class Retriever a where-  -- | Retrieve documents relevant to the query-  ---  --   Example:-  ---  --   >>> _get_relevant_documents (VectorStoreRetriever myStore) "AI"-  --   Right [Document "AI definition...", ...]-  _get_relevant_documents :: a -> Text -> IO (Either String [Document])+  {- | Retrieve documents relevant to the query +  Example:++  >>> _get_relevant_documents (VectorStoreRetriever myStore) "AI"+  Right [Document "AI definition...", ...]+  -}+  _get_relevant_documents :: a -> Text -> IO (LangchainResult [Document])++  _get_relevant_documentsM :: MonadIO m => a -> Text -> m (LangchainResult [Document])+  _get_relevant_documentsM retriever query = liftIO $ _get_relevant_documents retriever query+ {- | Vector store-backed retriever implementation Wraps any 'VectorStore' instance to provide similarity-based retrieval. @@ -108,7 +113,7 @@   type RunnableInput (VectorStoreRetriever a) = Text   type RunnableOutput (VectorStoreRetriever a) = [Document] -  invoke retriever query = _get_relevant_documents retriever query+  invoke = _get_relevant_documents  {- $examples Test case patterns:

@@ -50,6 +50,7 @@ import qualified Data.Map.Strict as HM import Data.Text (Text) import qualified Data.Text as T+import Langchain.Error (LangchainError, llmError)  {- | Query generation prompt template Controls how the LLM generates multiple query variants from the original query.@@ -85,8 +86,7 @@             ]       } -{- | Configuration for multi-query retrieval--}+-- | Configuration for multi-query retrieval data MultiQueryRetrieverConfig = MultiQueryRetrieverConfig   { numQueries :: Int   -- ^ Number of queries to generate@@ -176,7 +176,7 @@ Right ["Haskell", "Haskell features", "Haskell applications"] -} generateQueries ::-  LLM m => m -> QueryGenerationPrompt -> Text -> Int -> Bool -> IO (Either String [Text])+  LLM m => m -> QueryGenerationPrompt -> Text -> Int -> Bool -> IO (Either LangchainError [Text]) generateQueries model (QueryGenerationPrompt promptTemplate) query n includeOriginal = do   let vars = HM.fromList [("query", query), ("num_queries", T.pack $ show n)]   case renderPrompt promptTemplate vars of@@ -186,8 +186,8 @@       case result of         Left err -> return $ Left err         Right response -> do-          case parse response :: Either String NumberSeparatedList of-            Left err -> return $ Left $ "Failed to parse LLM response: " ++ err+          case parse response :: Either LangchainError NumberSeparatedList of+            Left err -> return $ Left err             Right (NumberSeparatedList queries) -> do               let uniqueQueries = nub $ filter (not . T.null) queries               return $@@ -231,7 +231,7 @@         (includeOriginalQuery cfg)      case queriesResult of-      Left err -> return $ Left $ "Error generating queries: " ++ err+      Left err -> return $ Left err       Right queries -> do         -- Get documents for each query         results <- mapM (_get_relevant_documents baseRetriever) queries@@ -240,7 +240,7 @@         let validResults = rights results          if null validResults-          then return $ Left "No valid results from any query"+          then return $ Left (llmError "No valid results from any query" Nothing Nothing)           else return $ Right $ combineDocuments validResults  {-@@ -269,7 +269,7 @@   type RunnableInput (MultiQueryRetriever a m) = Text   type RunnableOutput (MultiQueryRetriever a m) = [Document] -  invoke r query = _get_relevant_documents r query+  invoke = _get_relevant_documents  {- $examples Test case patterns:

@@ -41,6 +41,7 @@   ) where  import Data.List (find)+import Langchain.Error (LangchainError) import Langchain.Runnable.Core  {- | Chains two 'Runnable' instances together sequentially.@@ -61,7 +62,7 @@   r1 ->   r2 ->   RunnableInput r1 ->-  IO (Either String (RunnableOutput r2))+  IO (Either LangchainError (RunnableOutput r2)) chain r1 r2 input = do   output1 <- invoke r1 input   case output1 of@@ -86,7 +87,7 @@   r1 ->   r2 ->   a ->-  IO (Either String (RunnableOutput r1, RunnableOutput r2))+  IO (Either LangchainError (RunnableOutput r1, RunnableOutput r2)) branch r1 r2 input = do   result1 <- invoke r1 input   result2 <- invoke r2 input@@ -121,7 +122,7 @@ :} Right "This is a question, so I'm handling it with the question processor." -}-runBranch :: RunnableBranch a b -> a -> IO (Either String b)+runBranch :: RunnableBranch a b -> a -> IO (Either LangchainError b) runBranch (RunnableBranch options defaultR) input =   case find (\(cond, _) -> cond input) options of     Just (_, r) -> invoke r input@@ -156,7 +157,7 @@ :} Right False -}-runMap :: RunnableMap a b c -> a -> IO (Either String c)+runMap :: RunnableMap a b c -> a -> IO (Either LangchainError c) runMap (RunnableMap inputFn outputFn r) input = do   result <- invoke r (inputFn input)   return $ fmap outputFn result@@ -185,7 +186,7 @@     RunnableSequence a b -- RSCons adds a runnable at the front of the chain.  -- | Run a sequence of runnables, chaining the output of one as input to the next.-runSequence :: RunnableSequence a b -> RunnableInputHead a -> IO (Either String b)+runSequence :: RunnableSequence a b -> RunnableInputHead a -> IO (Either LangchainError b) runSequence RSNil input = return (Right input) runSequence (RSCons r rs) input = do   result <- invoke r input@@ -240,7 +241,7 @@ -} appendSequence ::   ( Runnable r2-  , RunnableOutput (RunnableSequence a b) ~ (RunnableInput r2)+  , RunnableOutput (RunnableSequence a b) ~ RunnableInput r2   ) =>   RunnableSequence a b ->   r2 ->@@ -260,7 +261,7 @@   r1 ->   r2 ->   RunnableInput r1 ->-  IO (Either String (RunnableOutput r2))+  IO (Either LangchainError (RunnableOutput r2)) (|>>) = chain  infix 4 |>>

@@ -1,4 +1,3 @@-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-}  {- |@@ -32,6 +31,7 @@     ConversationChain (..)   ) where +import Control.Monad.Trans.Except import Data.Text (Text) import Langchain.LLM.Core import Langchain.Memory.Core@@ -153,24 +153,9 @@   --  response3 <- invoke chatbot "Can you explain it in simpler terms?"   --  @   ---  invoke ConversationChain {..} input = do-    -- Add user message to memory-    updatedMemResult <- addUserMessage memory input-    case updatedMemResult of-      Left err -> return $ Left err-      Right updatedMem -> do-        -- Get all messages-        messagesResult <- messages updatedMem-        case messagesResult of-          Left err -> return $ Left err-          Right allMessages -> do-            -- Format messages for the LLM-            let formattedMessages = allMessages-            -- Get response from LLM-            llmResponse <- chat llm formattedMessages Nothing-            case llmResponse of-              Left err -> return $ Left err-              Right response -> do-                -- Store AI response in memory-                _ <- addAiMessage updatedMem response-                return $ Right response+  invoke chain input = runExceptT $ do+    updatedMem <- ExceptT $ addUserMessage (memory chain) input+    allMessages <- ExceptT $ messages updatedMem+    response <- ExceptT $ chat (llm chain) allMessages Nothing+    _ <- ExceptT $ addAiMessage updatedMem (content response)+    return $ content response

@@ -29,6 +29,9 @@   ( Runnable (..)   ) where +import Control.Monad.IO.Class (MonadIO, liftIO)+import Langchain.Error (LangchainResult)+ {- | The core 'Runnable' typeclass represents anything that can "run" with an input and produce an output.  This typeclass is the foundation of the LangChain Expression Language (LCEL) in Haskell,@@ -56,76 +59,49 @@ @ -} class Runnable r where-  -- | The type of input the runnable accepts.-  ---  -- For example, an LLM might accept 'String' or 'PromptValue' as input.+  {- | The type of input the runnable accepts.++  For example, an LLM might accept 'String' or 'PromptValue' as input.+  -}   type RunnableInput r -  -- | The type of output the runnable produces.-  ---  -- For example, an LLM might produce 'String' or 'LLMResult' as output.+  {- | The type of output the runnable produces.++  For example, an LLM might produce 'String' or 'LLMResult' as output.+  -}   type RunnableOutput r -  -- | Core method to invoke (run) this component with a single input.-  ---  --   This is the primary method that must be implemented for any 'Runnable'.-  --   It processes a single input and returns either an error message or the output.-  ---  --   Example usage:-  ---  --   @-  --   let model = OpenAI { temperature = 0.7, model = "gpt-3.5-turbo" }-  --   result <- invoke model "Explain monads in simple terms."-  --   case result of-  --     Left err -> putStrLn $ "Error: " ++ err-  --     Right response -> putStrLn response-  --   @-  invoke :: r -> RunnableInput r -> IO (Either String (RunnableOutput r))+  {- | Core method to invoke (run) this component with a single input. -  -- | Batch process multiple inputs at once.-  ---  --   This method can be overridden to provide more efficient batch processing,-  --   particularly for components like LLMs that may have batch APIs.-  ---  --   The default implementation simply maps 'invoke' over each input and-  --   sequences the results.-  ---  --   Example usage:-  ---  --   @-  --   let retriever = VectorDBRetriever { ... }-  --   questions <- ["What is Haskell?", "Explain monads.", "How do I install GHC?"]-  --   result <- batch retriever questions-  --   case result of-  --     Left err -> putStrLn $ "Batch processing failed: " ++ err-  --     Right docs -> mapM_ print docs-  --   @-  batch :: r -> [RunnableInput r] -> IO (Either String [RunnableOutput r])+  This is the primary method that must be implemented for any 'Runnable'.+  It processes a single input and returns either an error message or the output. +  Example usage:++  @+  let model = OpenAI { temperature = 0.7, model = "gpt-3.5-turbo" }+  result <- invoke model "Explain monads in simple terms."+  case result of+    Left err -> putStrLn $ "Error: " ++ err+    Right response -> putStrLn response+  @+  -}+  invoke :: r -> RunnableInput r -> IO (LangchainResult (RunnableOutput r))++  invokeM :: MonadIO m => r -> RunnableInput r -> m (LangchainResult (RunnableOutput r))+  invokeM runnable input = liftIO $ invoke runnable input++  batch :: r -> [RunnableInput r] -> IO (LangchainResult [RunnableOutput r])++  batchM :: MonadIO m => r -> [RunnableInput r] -> m (LangchainResult [RunnableOutput r])+  batchM runnable inputs = liftIO $ batch runnable inputs+   -- | Default implementation of batch that processes each input sequentially   batch r inputs = do     results <- mapM (invoke r) inputs     return $ sequence results -  -- | Stream results for components that support streaming.-  ---  --   This method is particularly useful for LLMs that can stream tokens as they're-  --   generated, allowing for more responsive user interfaces.-  ---  --   The callback function is called with each piece of the output as it becomes available.-  ---  --   Example usage:-  ---  --   @-  --   let model = OpenAI { temperature = 0.7, model = "gpt-3.5-turbo", streaming = True }-  --   result <- stream model "Write a story about a programmer." $ \chunk -> do-  --     putStr chunk-  --     hFlush stdout-  --   case result of-  --     Left err -> putStrLn $ "\\nError: " ++ err-  --     Right _ -> putStrLn "\\nStreaming completed successfully."-  --   @-  stream :: r -> RunnableInput r -> (RunnableOutput r -> IO ()) -> IO (Either String ())+  stream :: r -> RunnableInput r -> (RunnableOutput r -> IO ()) -> IO (LangchainResult ())    -- | Default implementation that invokes the runnable and then calls the callback with the full result   stream r input callback = do@@ -135,3 +111,7 @@       Right output -> do         callback output         return $ Right ()++  streamM ::+    MonadIO m => r -> RunnableInput r -> (RunnableOutput r -> IO ()) -> m (LangchainResult ())+  streamM runnable input callback = liftIO $ stream runnable input callback