diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,11 @@ All notable changes to this package will be documented in this file. +## 0.0.6.0 - 2026-10-02 + +- Updated bounds for GHC 9.12 and modern Stackage LTS releases. +- Standalone stack configuration and verified test suite. + ## 0.0.5.0 - 2026-09-10 - Initial standalone Hackage release of `langchain-hs-core`. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,24 +1,48 @@ # `langchain-hs-core` -> Zero-dependency pure core of the `langchain-hs` ecosystem. +> The foundational, effect-polymorphic core framework of the `langchain-hs` AI ecosystem. -`langchain-hs-core` provides pure GADT abstract syntax trees, effect-polymorphic chat models, streaming protocols, tools, and decoupled monads without ANY HTTP or network dependencies. +`langchain-hs-core` provides pure GADT abstract syntax trees, effect-polymorphic chat models, streaming protocols, tools, agents, vector stores, retrievers, document loaders, memory, cache, output parsers, guardrails, resilience, observability, and the canonical `Langchain.Prelude` without concrete provider-specific dependencies. -## Key Primitives +## Key Primitives & Modules -- **`RunnableTree m a b`**: Pure GADT abstract syntax tree for pipeline composition via `|>>` (sequential), `&>&` (parallel), and `>>>#` (fallback). -- **`ChatModel m`**: Effect-polymorphic typeclass for LLMs. -- **`ContentBlock`**: Multi-modal message content (text, image, tool calls, tool results). -- **`Tool` & `FunctionDefinition`**: Strongly-typed tool execution and JSON parameter schemas. -- **`StreamEvent` & `LLMChunk`**: Conduit-based incremental token streaming. -- **`LangchainT env m a`**: Decoupled reader monad transformer parameterized over custom environment `env`. +- **Runnables & Pure ASTs (`Langchain.Runnable`)**: Pure GADT abstract syntax tree (`RunnableTree m i o`) for pipeline composition via `|>>` (sequential), `&>&` (parallel fan-out), `runLambda`, `runPrim`, and deferred evaluation via `interpret`. +- **Chat Models & Types (`Langchain.Model`, `Langchain.Model.Types`)**: Effect-polymorphic `ChatModel` typeclass, `Message`, `Role`, `ContentBlock` (multi-modal text, images, tool calls, tool results). +- **Streaming Protocols (`Langchain.Stream`)**: Conduit-based incremental token streaming via `StreamEvent` and `LLMChunk`. +- **Tools & Dynamic Calling (`Langchain.Tool`, `Langchain.Tool.Binding`)**: Effect-polymorphic `Tool m`, `createTool`, Generic Schemas, and built-in tools (`Calculator`, `FileSystem`, `Shell`). Provider-agnostic tool binding via `ToolBinder`. +- **Agents (`Langchain.Agent.ReAct`, `Langchain.Agent.PlanAndExecute`)**: + - **ReAct Agent**: Full reasoning + acting agent loop with tool inspection, memory integration, callbacks, and step traces. + - **Plan-and-Execute Agent**: Two-phase agent decomposing complex user goals into discrete execution plans. +- **Prompt Templates (`Langchain.PromptTemplate`)**: String prompt templates with `{var}` f-string interpolation and pre-bound partial variables. +- **Vector Stores (`Langchain.VectorStore`)**: Abstract `VectorStore` typeclass and thread-safe `InMemoryVectorStore`. +- **Retrievers (`Langchain.Retriever`)**: BM25 keyword search (`BM25Retriever`), vector similarity retriever, and Reciprocal Rank Fusion (`HybridRetriever`). +- **Document Loaders & Text Splitters (`Langchain.DocumentLoader`, `Langchain.TextSplitter`)**: `Document` metadata abstraction and splitters for character chunks, Markdown, programming code, and tokens. +- **Memory & Cache (`Langchain.Memory`, `Langchain.Cache`)**: `BaseMemory`, `ConversationBufferMemory`, `WindowBufferMemory`, and STM-backed in-memory `LLMCache`. +- **Output Parsers (`Langchain.OutputParser`)**: Strongly typed JSON Schema generation (`JsonOutputParser`) and structured parsing. +- **Guardrails & Safety (`Langchain.Guardrails`)**: Input and output content moderation, PII redaction, and semantic safety validations. +- **Resilience & Fault Tolerance (`Langchain.Resilience`)**: State-machine `CircuitBreaker`, exponential backoff `RetryConfig`, and fallback handlers. +- **Observability & Tracing (`Langchain.Observability`, `Langchain.Callback`)**: OpenTelemetry distributed tracing spans, structured JSON event logging, and lifecycle event callbacks. +- **Chains (`Langchain.Chain.RetrievalQA`)**: End-to-end question answering pipeline over indexed knowledge bases. +- **Langchain Monad (`Langchain.Monad`)**: Decoupled `LangchainT env m a` reader and error transformer. +- **Canonical Prelude (`Langchain.Prelude`)**: Batteries-included single-import entry point providing the full core framework API. ## Installation +Add to your `cabal` or `package.yaml` dependencies: + ```cabal -build-depends: langchain-hs-core >= 0.0.5 && < 0.0.6 +build-depends: + langchain-hs-core >= 0.0.6.0 && < 0.0.7.0 ``` +To connect concrete LLMs, combine with satellite provider packages: +- `langchain-hs-ollama`: Local & offline models (Llama 3, DeepSeek, Gemma). +- `langchain-hs-openai`: OpenAI, OpenRouter, and OpenAI-compatible cloud endpoints. +- `langchain-hs-gemini`: Google Gemini with multi-modal support. +- `langchain-hs-mcp`: Model Context Protocol tool client. + +For cyclic state machines, checkpointers, and multi-agent coordination, add `langchain-hs-graph` (or use the umbrella `langchain-hs` package). + ## License -MIT License. See [LICENSE](LICENSE). +Distributed under the **MIT License**. See [LICENSE](LICENSE) for details. diff --git a/langchain-hs-core.cabal b/langchain-hs-core.cabal --- a/langchain-hs-core.cabal +++ b/langchain-hs-core.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: langchain-hs-core -version: 0.0.5.0 +version: 0.0.6.0 synopsis: Core typeclasses and pure AST primitives for langchain-hs description: Zero HTTP dependency core package containing ChatModel, RunnableTree, ContentBlock, Tool, and StreamEvent primitives. category: Web, AI, Control @@ -31,13 +31,67 @@ library exposed-modules: - Langchain.Core.Error - Langchain.Core.Model - Langchain.Core.Model.Types - Langchain.Core.Monad - Langchain.Core.Stream - Langchain.Core.Runnable - Langchain.Core.Tool + Langchain.Error + Langchain.Model + Langchain.Model.Types + Langchain.Monad + Langchain.Stream + Langchain.Runnable + Langchain.Tool + Langchain.Tool.Binding + Langchain.Tool.Checkpoint + Langchain.Tool.Core + Langchain.Tool.FileSystem + Langchain.Tool.GenericSchema + Langchain.Tool.Process + Langchain.Tool.Security + Langchain.Tool.Shell + Langchain.Embeddings + Langchain.Embeddings.Core + Langchain.DocumentLoader + Langchain.DocumentLoader.Core + Langchain.DocumentLoader.DirectoryLoader + Langchain.DocumentLoader.FileLoader + Langchain.TextSplitter.Character + Langchain.TextSplitter.Code + Langchain.TextSplitter.Markdown + Langchain.TextSplitter.RecursiveCharacter + Langchain.TextSplitter.Token + Langchain.VectorStore + Langchain.VectorStore.Core + Langchain.VectorStore.InMemory + Langchain.PromptTemplate + Langchain.PromptTemplate.Prompt + Langchain.PromptTemplate.String + Langchain.Observability + Langchain.Callback + Langchain.Callback.Manager + Langchain.Retriever + Langchain.Retriever.Core + Langchain.Retriever.BM25 + Langchain.Retriever.Hybrid + Langchain.Resilience + Langchain.Resilience.CircuitBreaker + Langchain.Resilience.Retry + Langchain.Memory + Langchain.Memory.Core + Langchain.Memory.Summary + Langchain.Memory.Session + Langchain.Memory.Entity + Langchain.Memory.Combined + Langchain.Cache + Langchain.Cache.Core + Langchain.OutputParser + Langchain.OutputParser.Core + Langchain.OutputParser.Structured + Langchain.Chain + Langchain.Chain.RetrievalQA + Langchain.Agent + Langchain.Agent.ReAct + Langchain.Agent.PlanAndExecute + Langchain.Guardrail + Langchain.Guardrail.Core + Langchain.Prelude other-modules: Paths_langchain_hs_core hs-source-dirs: @@ -62,9 +116,15 @@ , bytestring >=0.10 && <0.13 , conduit ==1.3.* , containers >=0.6 && <0.9 - , deepseq >=1.4 && <1.6 + , directory ==1.3.* + , filepath >=1.4 && <2 + , format-heavy ==0.1.* , mtl >=2.2 && <2.4 + , process ==1.6.* + , random >=1.2 && <1.4 , resourcet >=1.2 && <1.4 + , scientific ==0.3.* + , sqlite-simple >=0.4.18 && <0.5 , stm ==2.5.* , text >=1.2 && <3 , time >=1.9 && <1.15 @@ -74,12 +134,17 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - Test.Langchain.Core.Model - Test.Langchain.Core.Monad - Test.Langchain.Core.Runnable - Test.Langchain.Core.Stream - Test.Langchain.Core.TestModel - Test.Langchain.Core.Tool + Test.Langchain.Callback + Test.Langchain.Model + Test.Langchain.Monad + Test.Langchain.Observability + Test.Langchain.PromptTemplate + Test.Langchain.Resilience + Test.Langchain.Retriever + Test.Langchain.Runnable + Test.Langchain.Stream + Test.Langchain.TestModel + Test.Langchain.Tool Paths_langchain_hs_core hs-source-dirs: test @@ -105,10 +170,16 @@ , bytestring >=0.10 && <0.13 , conduit ==1.3.* , containers >=0.6 && <0.9 - , deepseq >=1.4 && <1.6 + , directory ==1.3.* + , filepath >=1.4 && <2 + , format-heavy ==0.1.* , langchain-hs-core , mtl >=2.2 && <2.4 - , resourcet + , process ==1.6.* + , random >=1.2 && <1.4 + , resourcet >=1.2 && <1.4 + , scientific ==0.3.* + , sqlite-simple >=0.4.18 && <0.5 , stm ==2.5.* , tasty >=1.4 , tasty-hunit >=0.10 diff --git a/src/Langchain/Agent.hs b/src/Langchain/Agent.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Agent.hs @@ -0,0 +1,18 @@ +{- | +Module : Langchain.Agent +Description : Autonomous agents +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Autonomous agent architectures including ReAct (Reasoning and Acting) +and Plan-and-Execute multi-step workflows. +-} +module Langchain.Agent + ( module Langchain.Agent.ReAct + , module Langchain.Agent.PlanAndExecute + ) where + +import Langchain.Agent.PlanAndExecute +import Langchain.Agent.ReAct diff --git a/src/Langchain/Agent/PlanAndExecute.hs b/src/Langchain/Agent/PlanAndExecute.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Agent/PlanAndExecute.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | +Module : Langchain.Agent.PlanAndExecute +Description : Plan-and-Execute agent architecture using JSON structured output and effectful step executors +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Separates complex multi-step reasoning into a two-phase architecture: +1. Planner LLM generates an explicit sequence of structured steps as typed JSON. +2. Executor (an agent with tools, a function, or a model) executes each step sequentially with accumulated context. +-} +module Langchain.Agent.PlanAndExecute + ( PlanStep (..) + , Plan (..) + , StepExecutor (..) + , PlanAndExecuteAgent (..) + , newPlanAndExecuteAgent + , newPlanAndExecuteAgentWithTools + , runPlanAndExecute + ) where + +import Control.Applicative ((<|>)) +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.IO.Class (MonadIO) +import Data.Aeson (FromJSON (..), ToJSON, Value (..), withObject, (.!=), (.:), (.:?)) +import Data.Aeson.Types (prependFailure, typeMismatch) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) + +import Langchain.Agent.ReAct (ReActAgent, defaultReActAgent, runReActAgent) +import Langchain.Error (LangchainError, agentError) +import Langchain.Model + ( ChatModel (..) + , extractMessageText + , userMessage + ) +import Langchain.OutputParser.Structured (StructuredOutput, TypeSchema, structuredInvoke) +import Langchain.Tool (Tool) +import Langchain.Tool.Binding (ToolBinder (..)) + +-- | Single step in an execution plan +data PlanStep = PlanStep + { stepNumber :: !Int + , stepDescription :: !Text + } + deriving stock (Show, Eq, Generic) + deriving anyclass (ToJSON, TypeSchema) + +instance FromJSON PlanStep where + parseJSON = withObject "PlanStep" $ \o -> do + num <- + o .:? "stepNumber" >>= \case + Just n -> pure n + Nothing -> + o .:? "step" >>= \case + Just n -> pure n + Nothing -> o .:? "number" .!= 1 + desc <- + o .:? "stepDescription" >>= \case + Just d -> pure d + Nothing -> + o .:? "description" >>= \case + Just d -> pure d + Nothing -> + o .:? "task" >>= \case + Just d -> pure d + Nothing -> o .: "action" + pure $ PlanStep num desc + +-- | Collection of steps forming a plan +newtype Plan = Plan + { planSteps :: [PlanStep] + } + deriving stock (Show, Eq, Generic) + deriving anyclass (ToJSON, StructuredOutput, TypeSchema) + +instance FromJSON Plan where + parseJSON (Object o) = Plan <$> (o .: "planSteps" <|> o .: "steps" <|> o .: "plan") + parseJSON (Array arr) = Plan <$> parseJSON (Array arr) + parseJSON invalid = prependFailure "parsing Plan failed, " (typeMismatch "Object or Array" invalid) + +-- | Abstraction for executing individual steps of a plan (agents, models with tools, or custom runners) +class StepExecutor e m where + executeStep :: + -- | Step executor instance (agent, model with tools, or custom runner) + e -> + -- | Step instruction prompt to execute + Text -> + -- | Textual result produced by executing the step + m Text + +instance + {-# OVERLAPPING #-} + (ToolBinder model n, MonadIO n, MonadError LangchainError n) => + StepExecutor (ReActAgent model n) n + where + executeStep agent prompt = do + msg <- runReActAgent agent [userMessage prompt] + pure $ extractMessageText msg + +instance + {-# OVERLAPPING #-} + (ToolBinder model n, MonadIO n, MonadError LangchainError n) => + StepExecutor (model, [Tool n]) n + where + executeStep (model, tools) = + executeStep (defaultReActAgent model tools) + +instance {-# OVERLAPPING #-} (m ~ n) => StepExecutor (Text -> m Text) n where + executeStep = id + +instance {-# OVERLAPPABLE #-} (ChatModel model, MonadIO m, MonadError LangchainError m) => StepExecutor model m where + executeStep model prompt = do + msg <- invoke model [userMessage prompt] Nothing + pure $ extractMessageText msg + +-- | Plan-and-Execute agent container +data PlanAndExecuteAgent planner executor = PlanAndExecuteAgent + { plannerModel :: planner + , stepExecutor :: executor + , planPromptTemplate :: Maybe Text + } + +-- | Construct a new PlanAndExecuteAgent with any StepExecutor (agent, function, or model) +newPlanAndExecuteAgent :: + -- | LLM model responsible for creating the execution plan + planner -> + -- | StepExecutor instance used to carry out each plan step + executor -> + -- | Optional custom prompt template for the planner + Maybe Text -> + -- | Configured PlanAndExecuteAgent instance + PlanAndExecuteAgent planner executor +newPlanAndExecuteAgent = PlanAndExecuteAgent + +-- | Construct a PlanAndExecuteAgent with tools using a ReActAgent as the step executor +newPlanAndExecuteAgentWithTools :: + -- | LLM model responsible for creating the execution plan + planner -> + -- | LLM model for the ReAct step executor + model -> + -- | Available tools for the ReAct step executor + [Tool m] -> + -- | Optional custom prompt template for the planner + Maybe Text -> + -- | Configured PlanAndExecuteAgent with tool-enabled ReAct executor + PlanAndExecuteAgent planner (ReActAgent model m) +newPlanAndExecuteAgentWithTools planner model tools = + PlanAndExecuteAgent planner (defaultReActAgent model tools) + +-- | Execute a goal using the Plan-and-Execute workflow with structured JSON planning +runPlanAndExecute :: + (ChatModel planner, StepExecutor executor m, MonadIO m, MonadError LangchainError m) => + -- | Configured PlanAndExecuteAgent instance + PlanAndExecuteAgent planner executor -> + -- | High-level user goal to plan and solve + Text -> + -- | Final synthesized answer solving the user goal + m Text +runPlanAndExecute PlanAndExecuteAgent {..} userGoal = do + let planPrompt = case planPromptTemplate of + Just p -> p <> "\nGoal: " <> userGoal + Nothing -> + "You are an expert planner. For the following goal, generate a concise step-by-step execution plan.\n" + <> "Output JSON format: {\"planSteps\": [{\"stepNumber\": 1, \"stepDescription\": \"...\"}]}\n" + <> "Keep the plan focused and minimal (between 2 to 3 distinct, actionable steps).\n" + <> "Goal: " + <> userGoal + plan <- structuredInvoke plannerModel [userMessage planPrompt] + if null (planSteps plan) + then throwError $ agentError "Planner generated an empty plan" (Just "PlanAndExecuteAgent") Nothing + else executeSteps (planSteps plan) [] + where + executeSteps [] stepOutputs = do + let synthesisPrompt = + "User Goal: " + <> userGoal + <> "\n\nStep Execution History:\n" + <> T.unlines + [T.pack (show num) <> ". " <> desc <> " -> " <> out | (PlanStep num desc, out) <- stepOutputs] + <> "\n\nProvide the final synthesized answer satisfying the goal:" + executeStep stepExecutor synthesisPrompt + executeSteps (currStep : restSteps) prevOutputs = do + let stepPrompt = + "User Goal: " + <> userGoal + <> ( if null prevOutputs + then "" + else + "\n\nCompleted Steps So Far:\n" + <> T.unlines + [T.pack (show num) <> ". " <> desc <> " -> " <> out | (PlanStep num desc, out) <- prevOutputs] + ) + <> "\n\nCurrent Task To Execute (Step " + <> T.pack (show (stepNumber currStep)) + <> "): " + <> stepDescription currStep + <> "\nExecute this task using any appropriate tools available and provide the outcome:" + stepOut <- executeStep stepExecutor stepPrompt + executeSteps restSteps (prevOutputs ++ [(currStep, stepOut)]) diff --git a/src/Langchain/Agent/ReAct.hs b/src/Langchain/Agent/ReAct.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Agent/ReAct.hs @@ -0,0 +1,481 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +{- | +Module : Langchain.Agent.ReAct +Description : Effect-polymorphic ReAct (Reasoning + Acting) Agent +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +ReAct (Reasoning and Acting) agent loop that supports: + +* __Effect-polymorphic tools__: Tools operate in the agent's monad @m@. +* __Memory integration__: Pluggable 'BaseMemory' via 'withMemory'. +* __Model-specific configs__: Merged with tool definitions via 'withModelConfig'. +* __Observability__: Lifecycle hooks via 'withCallbackManager'. +* __Error resilience__: Configurable 'ToolErrorStrategy'. +* __Iteration limits__: Prevents infinite loops via 'withMaxIterations'. +* __Early stop conditions__: User-defined stopping predicates via 'withStopCondition'. +* __Reasoning traces__: Inspection via 'runReActAgentWithTrace'. + +=== Quick Start + +@ +let tools = [shellTool] +let agent = defaultReActAgent model tools +result <- runReActAgent agent [userMessage "What is 2+2?"] +@ + +=== With Memory and Tracing + +@ +mem <- newWindowBufferMemory 10 [] +let agent = + withMemory mem $ + withSystemPrompt "You are a helpful math tutor." $ + defaultReActAgent model tools +trace <- runReActAgentWithTrace agent [userMessage "What is the square root of 144?"] +@ +-} +module Langchain.Agent.ReAct + ( -- * Core Types + AgentStep (..) + , AgentTrace (..) + , ReActAgent (..) + , ToolErrorStrategy (..) + + -- * Construction + , defaultReActAgent + + -- * Configuration (builder-style) + , withMemory + , withoutMemory + , withSystemPrompt + , withMaxIterations + , withModelConfig + , withCallbackManager + , withStopCondition + , withToolErrorStrategy + + -- * Execution + , reactStep + , runReActAgent + , runReActAgentWithTrace + ) where + +import Control.Monad (forM, when) +import Control.Monad.Except (MonadError, catchError, throwError) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.List (find) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (diffUTCTime, getCurrentTime) + +import Langchain.Callback.Manager (CallbackEvent (..), CallbackManager, dispatchEvent) +import Langchain.Error (LangchainError, agentError, errorMessage) +import Langchain.Memory.Core (BaseMemory (..), SomeMemory (..)) +import Langchain.Model +import qualified Langchain.Model.Types as M +import Langchain.Tool +import Langchain.Tool.Binding (ToolBinder (..)) + +-- | How the agent handles tool execution failures. +data ToolErrorStrategy + = -- | Feed the error message back to the LLM as a Tool observation so it can retry or recover. + ContinueOnError + | -- | Abort the entire agent loop immediately on any tool error. + FailOnError + deriving (Eq, Show) + +-- | A single step in the ReAct reasoning chain. +data AgentStep + = -- | The model decided to call one or more tools. + AgentAction Message [ToolCall] + | -- | The model produced a final answer (no tool calls). + AgentFinish Message + deriving (Eq, Show) + +-- | Complete reasoning trace: intermediate steps + final answer. +data AgentTrace = AgentTrace + { traceSteps :: [(AgentStep, [Message])] + -- ^ Each pair is (the step, observation messages produced) + , traceFinalAnswer :: Message + -- ^ The final answer message + } + deriving (Eq, Show) + +{- | ReAct Agent configuration. + +Holds the LLM model, the effect-polymorphic tools @[Tool m]@, and optional +configuration for memory, callbacks, iterations, model config, and error strategy. +Use 'defaultReActAgent' to construct, then configure with the @with*@ builder functions. +-} +data ReActAgent model m = ReActAgent + { agentModel :: model + -- ^ The LLM model backing this agent + , agentTools :: [Tool m] + -- ^ Available tools the agent can invoke in monad @m@ + , agentMaxIterations :: Int + -- ^ Maximum reasoning iterations before giving up (default: 100) + , agentSystemPrompt :: Maybe Text + -- ^ Optional system prompt prepended to every invocation + , agentModelConfig :: Maybe (ModelConfig model) + -- ^ Optional provider-specific model configuration (temperature, top_p, etc.) + , agentMemory :: Maybe SomeMemory + -- ^ Optional 'BaseMemory' for persistent conversation history + , agentCallbackManager :: Maybe CallbackManager + -- ^ Optional callback manager for observability hooks + , agentStopCondition :: Maybe (Message -> Bool) + -- ^ Optional early-stop predicate checked after each LLM response + , agentToolErrorStrategy :: ToolErrorStrategy + -- ^ How to handle tool execution errors (default: 'ContinueOnError') + } + +{- | Construct a ReAct agent with sensible defaults. + +All optional fields start as 'Nothing' / defaults. Use the @with*@ functions to configure. +-} +defaultReActAgent :: + -- | The LLM chat model backing this agent + model -> + -- | Available effect-polymorphic tools + [Tool m] -> + -- | Initialized ReActAgent with default settings + ReActAgent model m +defaultReActAgent model tools = + ReActAgent + { agentModel = model + , agentTools = tools + , agentMaxIterations = 100 + , agentSystemPrompt = Nothing + , agentModelConfig = Nothing + , agentMemory = Nothing + , agentCallbackManager = Nothing + , agentStopCondition = Nothing + , agentToolErrorStrategy = ContinueOnError + } + +{- | Attach a 'BaseMemory' instance for persistent conversation history. + +When memory is set, 'runReActAgent' will: + +1. Load existing messages from memory before the first LLM call. +2. Save the user query + final answer to memory after completion. +-} +withMemory :: + (BaseMemory mem) => + -- | BaseMemory instance to store conversation messages + mem -> + -- | Current agent instance + ReActAgent model m -> + -- | Agent configured with persistent memory + ReActAgent model m +withMemory mem agent = agent {agentMemory = Just (SomeMemory mem)} + +-- | Remove memory from the agent. +withoutMemory :: + -- | Current agent instance + ReActAgent model m -> + -- | Agent with memory detached + ReActAgent model m +withoutMemory agent = agent {agentMemory = Nothing} + +-- | Set the system prompt that instructs the agent's persona and behavior. +withSystemPrompt :: + -- | System instructions / persona text + Text -> + -- | Current agent instance + ReActAgent model m -> + -- | Agent configured with system prompt + ReActAgent model m +withSystemPrompt prompt agent = agent {agentSystemPrompt = Just prompt} + +-- | Override the maximum number of reasoning iterations (default: 10). +withMaxIterations :: + -- | Maximum reasoning loop iterations before aborting + Int -> + -- | Current agent instance + ReActAgent model m -> + -- | Agent configured with iteration limit + ReActAgent model m +withMaxIterations n agent = agent {agentMaxIterations = n} + +{- | Attach a provider-specific model configuration (temperature, top_p, etc.). + +This config is merged with the tool-binding config on every 'invoke' call, +giving you full control over LLM parameters without losing tool support. +-} +withModelConfig :: + -- | Provider-specific model configuration (temperature, top_p, etc.) + Maybe (ModelConfig model) -> + -- | Current agent instance + ReActAgent model m -> + -- | Agent configured with model options + ReActAgent model m +withModelConfig cfg agent = agent {agentModelConfig = cfg} + +{- | Attach a 'CallbackManager' for observability. + +When set, the agent emits 'OnToolStart' / 'OnToolEnd' / 'OnError' events +for each tool invocation in the reasoning loop. +-} +withCallbackManager :: + -- | Callback manager for observability event hooks + CallbackManager -> + -- | Current agent instance + ReActAgent model m -> + -- | Agent configured with callback manager + ReActAgent model m +withCallbackManager mgr agent = agent {agentCallbackManager = Just mgr} + +{- | Set a custom stop condition checked after each LLM response. + +If the predicate returns 'True' for the LLM's response message, the agent +immediately returns that message as the final answer, even if the LLM +included tool calls. +-} +withStopCondition :: + -- | Predicate checked after each LLM response for early exit + (Message -> Bool) -> + -- | Current agent instance + ReActAgent model m -> + -- | Agent configured with custom stopping condition + ReActAgent model m +withStopCondition cond agent = agent {agentStopCondition = Just cond} + +{- | Set the tool error handling strategy. + +* 'ContinueOnError' (default): feed error text back to the LLM as a Tool observation. +* 'FailOnError': abort the entire agent loop on the first tool error. +-} +withToolErrorStrategy :: + -- | Strategy on tool failure ('ContinueOnError' or 'FailOnError') + ToolErrorStrategy -> + -- | Current agent instance + ReActAgent model m -> + -- | Agent configured with error handling strategy + ReActAgent model m +withToolErrorStrategy strategy agent = agent {agentToolErrorStrategy = strategy} + +{- | Run a single step of ReAct reasoning. + +Sends the current message history (with tools bound) to the LLM and +classifies the response as either 'AgentAction' (tool calls requested) +or 'AgentFinish' (final answer). +-} +reactStep :: + forall model m. + (ToolBinder model m, MonadIO m, MonadError LangchainError m) => + -- | The chat model to invoke + model -> + -- | Available tools to bind to the model + [Tool m] -> + -- | Current conversation message history + [Message] -> + -- | Optional provider-specific model configuration + Maybe (ModelConfig model) -> + -- | Step classification: 'AgentAction' or 'AgentFinish' + m AgentStep +reactStep model tools history userCfg = do + let toolCfg = bindToolsConfig @model tools userCfg + responseMsg <- invoke model history toolCfg + case messageToolCalls responseMsg of + Just tcs@(_ : _) -> pure $ AgentAction responseMsg tcs + _ -> pure $ AgentFinish responseMsg + +{- | Execute the full ReAct reasoning loop, returning only the final answer. + +For the full reasoning trace, use 'runReActAgentWithTrace'. + +When the agent has a 'BaseMemory' attached: + +1. Existing conversation history is loaded from memory. +2. The user's input messages are appended. +3. After the loop finishes, both the user input and final answer are saved to memory. +-} +runReActAgent :: + forall model m. + (ToolBinder model m, MonadIO m, MonadError LangchainError m) => + -- | Configured ReAct agent instance + ReActAgent model m -> + -- | Input user messages for this turn + [Message] -> + -- | The final assistant answer message + m Message +runReActAgent agent userMsgs = traceFinalAnswer <$> runReActAgentWithTrace agent userMsgs + +{- | Execute the full ReAct reasoning loop, returning both the final answer +and the complete intermediate reasoning trace. + +Tool calls within a single step are executed in sequence within the @m@ monad, +and the observations are fed back to the LLM for the next reasoning step. + +The trace includes every 'AgentStep' and the observation messages produced +at each iteration, which is invaluable for debugging and observability. +-} +runReActAgentWithTrace :: + forall model m. + (ToolBinder model m, MonadIO m, MonadError LangchainError m) => + -- | Configured ReAct agent instance + ReActAgent model m -> + -- | Input user messages for this turn + [Message] -> + -- | Full reasoning trace containing all intermediate steps and final answer + m AgentTrace +runReActAgentWithTrace ReActAgent {..} userMsgs = do + -- 1. Build initial history: system prompt + memory + user messages + memoryMsgs <- case agentMemory of + Nothing -> pure [] + Just (SomeMemory mem) -> messages mem + + -- When an explicit agent system prompt is provided, avoid duplicate system prompts + -- by stripping any default system prompt that may already exist in memory. + let memWithoutSystem = case agentSystemPrompt of + Just _ -> filter (\m -> messageRole m /= System) memoryMsgs + Nothing -> memoryMsgs + sysPrefix = maybe [] (\p -> [systemMessage p]) agentSystemPrompt + initialHistory = sysPrefix ++ memWithoutSystem ++ userMsgs + + when (null initialHistory) $ + throwError $ + agentError + "Cannot invoke ReAct agent with empty message history (no user query, memory, or system prompt)" + (Just "ReActAgent") + (Just "runReActAgentWithTrace") + + -- 2. Run the reasoning loop + trace <- go initialHistory agentMaxIterations [] + + -- 3. Persist to memory if available + case agentMemory of + Nothing -> pure () + Just (SomeMemory mem) -> do + -- Save each user message + mapM_ (addMessage mem) userMsgs + -- Save the final answer + addMessage mem (traceFinalAnswer trace) + + pure trace + where + go :: [Message] -> Int -> [(AgentStep, [Message])] -> m AgentTrace + go history maxIter accSteps + | maxIter <= 0 = do + let maxErr = + "ReAct Agent exceeded maximum iterations (" + <> T.pack (show agentMaxIterations) + <> ")" + case agentCallbackManager of + Nothing -> pure () + Just mgr -> do + now <- liftIO getCurrentTime + dispatchEvent mgr (OnError "ReActAgent" maxErr now) + throwError $ + agentError + maxErr + (Just "ReActAgent") + (Just "runReActAgent") + | otherwise = do + -- Dispatch OnLLMStart callback before calling model + llmStartTime <- liftIO getCurrentTime + case agentCallbackManager of + Nothing -> pure () + Just mgr -> + dispatchEvent mgr (OnLLMStart "ReActAgent" (map extractMessageText history) llmStartTime) + + -- Invoke the model with error interception for observability + eStep <- + (Right <$> reactStep agentModel agentTools history agentModelConfig) + `catchError` (pure . Left) + llmEndTime <- liftIO getCurrentTime + let llmLatency = round (realToFrac (diffUTCTime llmEndTime llmStartTime) * 1000000 :: Double) :: Int + case eStep of + Left err -> do + case agentCallbackManager of + Nothing -> pure () + Just mgr -> + dispatchEvent mgr (OnError "ReActAgent" (errorMessage err) llmEndTime) + throwError err + Right step -> case step of + AgentFinish finalMsg -> do + case agentCallbackManager of + Nothing -> pure () + Just mgr -> + dispatchEvent mgr (OnLLMEnd "ReActAgent" (extractMessageText finalMsg) llmLatency llmEndTime) + let allSteps = accSteps ++ [(step, [])] + pure $ AgentTrace allSteps finalMsg + AgentAction respMsg tcs -> do + case agentCallbackManager of + Nothing -> pure () + Just mgr -> + dispatchEvent mgr (OnLLMEnd "ReActAgent" (extractMessageText respMsg) llmLatency llmEndTime) + + -- Check custom stop condition + case agentStopCondition of + Just cond | cond respMsg -> do + let allSteps = accSteps ++ [(step, [])] + pure $ AgentTrace allSteps respMsg + _ -> do + obsMsgs <- forM tcs executeTool + let newHistory = history ++ [respMsg] ++ obsMsgs + newSteps = accSteps ++ [(step, obsMsgs)] + go newHistory (maxIter - 1) newSteps + + executeTool :: ToolCall -> m Message + executeTool tc = do + let tName = toolCallName tc + case agentCallbackManager of + Nothing -> pure () + Just mgr -> do + now <- liftIO getCurrentTime + dispatchEvent mgr (OnToolStart tName (toolCallArguments tc) now) + + case find (\t -> toolName t == tName) agentTools of + Nothing -> do + let notFoundMsg = "Error: Tool not found: " <> tName + case agentCallbackManager of + Nothing -> pure () + Just mgr -> do + now <- liftIO getCurrentTime + dispatchEvent mgr (OnError tName notFoundMsg now) + when (agentToolErrorStrategy == FailOnError) $ + throwError $ + agentError notFoundMsg (Just "ReActAgent") (Just $ "executeTool:" <> tName) + pure $ + (textMessage M.Tool notFoundMsg) + { M.messageName = Just tName + , M.messageToolId = Just (toolCallId tc) + } + Just tool -> do + startTime <- liftIO getCurrentTime + eRes <- toolExecute tool (toolCallArguments tc) + endTime <- liftIO getCurrentTime + let durationMicros = round (realToFrac (diffUTCTime endTime startTime) * 1000000 :: Double) :: Int + case eRes of + Left err -> do + let errTxt = "Error executing tool " <> tName <> ": " <> errorMessage err + case agentCallbackManager of + Nothing -> pure () + Just mgr -> dispatchEvent mgr (OnError tName errTxt endTime) + when (agentToolErrorStrategy == FailOnError) $ + throwError $ + agentError errTxt (Just "ReActAgent") (Just $ "executeTool:" <> tName) + pure $ + (textMessage M.Tool errTxt) + { M.messageName = Just tName + , M.messageToolId = Just (toolCallId tc) + } + Right outTxt -> do + case agentCallbackManager of + Nothing -> pure () + Just mgr -> dispatchEvent mgr (OnToolEnd tName outTxt durationMicros endTime) + pure $ + (textMessage M.Tool outTxt) + { M.messageName = Just tName + , M.messageToolId = Just (toolCallId tc) + } diff --git a/src/Langchain/Cache.hs b/src/Langchain/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Cache.hs @@ -0,0 +1,15 @@ +{- | +Module : Langchain.Cache +Description : LLM response caching layer +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Transparent caching for ChatModel invocations with in-memory and SQLite backends. +-} +module Langchain.Cache + ( module Langchain.Cache.Core + ) where + +import Langchain.Cache.Core diff --git a/src/Langchain/Cache/Core.hs b/src/Langchain/Cache/Core.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Cache/Core.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | +Module : Langchain.Cache.Core +Description : LLM response caching layer with in-memory and SQLite backends +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Transparent caching for ChatModel invocations to reduce latency, cost, and API usage. +-} +module Langchain.Cache.Core + ( CacheBackend (..) + , InMemoryCache (..) + , newInMemoryCache + , SQLiteCache (..) + , newSQLiteCache + , CachedModel (..) + , CacheableChatModel (..) + , withCaching + , computeCacheKey + ) +where + +import Control.Concurrent.STM +import Control.Exception (SomeException, try) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (ToJSON, Value, decode, encode, object, (.=)) +import qualified Data.ByteString.Lazy as LBS +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map + +import Data.Text (Text) +import qualified Data.Text as TS +import qualified Data.Text.Encoding as TE +import Database.SQLite.Simple +import Langchain.Model + ( ChatModel (..) + , Message (..) + ) +import Langchain.Tool.Binding (ToolBinder (..)) + +-- | Effect-polymorphic cache backend typeclass +class CacheBackend cb where + getCache :: (MonadIO m) => cb -> Text -> m (Maybe Message) + putCache :: (MonadIO m) => cb -> Text -> Message -> m () + clearCache :: (MonadIO m) => cb -> m () + +-- | Thread-safe in-memory cache backed by STM TVar +newtype InMemoryCache = InMemoryCache + { memCacheVar :: TVar (Map Text Message) + } + +-- | Construct a new InMemoryCache +newInMemoryCache :: (MonadIO m) => m InMemoryCache +newInMemoryCache = liftIO $ do + var <- newTVarIO Map.empty + pure $ InMemoryCache var + +instance CacheBackend InMemoryCache where + getCache InMemoryCache {..} key = liftIO $ do + m <- readTVarIO memCacheVar + pure $ Map.lookup key m + + putCache InMemoryCache {..} key msg = liftIO $ do + atomically $ modifyTVar' memCacheVar (Map.insert key msg) + + clearCache InMemoryCache {..} = liftIO $ do + atomically $ writeTVar memCacheVar Map.empty + +-- | Persistent SQLite cache backend +newtype SQLiteCache = SQLiteCache + { sqliteCacheDbPath :: FilePath + } + +-- | Construct a new SQLiteCache and create cache table +newSQLiteCache :: (MonadIO m) => FilePath -> m SQLiteCache +newSQLiteCache dbPath = liftIO $ do + _ <- + ( try $ withConnection dbPath $ \conn -> do + execute_ + conn + "CREATE TABLE IF NOT EXISTS langchain_cache (\ + \ cache_key TEXT PRIMARY KEY,\ + \ response_json TEXT NOT NULL,\ + \ created_at DATETIME DEFAULT CURRENT_TIMESTAMP\ + \);" + ) :: + IO (Either SomeException ()) + pure $ SQLiteCache dbPath + +instance CacheBackend SQLiteCache where + getCache SQLiteCache {..} key = liftIO $ do + rowsRes <- + ( try $ withConnection sqliteCacheDbPath $ \conn -> do + query conn "SELECT response_json FROM langchain_cache WHERE cache_key = ?" (Only (TS.unpack key)) :: + IO [Only String] + ) :: + IO (Either SomeException [Only String]) + case rowsRes of + Right [Only jsonStr] -> + let bs = LBS.fromStrict (TE.encodeUtf8 (TS.pack jsonStr)) + in pure (decode bs) + _ -> pure Nothing + + putCache SQLiteCache {..} key msg = liftIO $ do + let jsonStr = TS.unpack $ TE.decodeUtf8 $ LBS.toStrict (encode msg) + _ <- + ( try $ withConnection sqliteCacheDbPath $ \conn -> do + execute + conn + "INSERT OR REPLACE INTO langchain_cache (cache_key, response_json) VALUES (?, ?)" + (TS.unpack key, jsonStr) + ) :: + IO (Either SomeException ()) + pure () + + clearCache SQLiteCache {..} = liftIO $ do + _ <- + ( try $ withConnection sqliteCacheDbPath $ \conn -> do + execute_ conn "DELETE FROM langchain_cache;" + ) :: + IO (Either SomeException ()) + pure () + +-- | ChatModel wrapper that provides transparent response caching +data CachedModel model cache = CachedModel + { underlyingModel :: model + , modelCache :: cache + } + +{- | Wrap a cacheable chat model with a cache backend. + +The wrapped model uses the provider-specific identity supplied by +'CacheableChatModel' when looking up responses. +-} +withCaching :: model -> cache -> CachedModel model cache +withCaching = CachedModel + +-- | Encode a value as JSON text suitable for a cache key. +toJsonText :: (ToJSON a) => a -> Text +toJsonText = TE.decodeUtf8 . LBS.toStrict . encode + +{- | Provider-specific data that distinguishes cacheable model invocations. + +Implementations should include every model property and effective invocation +parameter that can affect a response, but must not include credentials. + +Instances for the built-in providers live in their respective sub-packages: + + * @langchain-hs-openai@: @CacheableChatModel OpenAI@ + * @langchain-hs-ollama@: @CacheableChatModel Ollama@ + * @langchain-hs-gemini@: @CacheableChatModel Gemini@ +-} +class (ChatModel model) => CacheableChatModel model where + -- | Return the JSON identity used to distinguish this model's cache entries. + cacheModelIdentity :: model -> Maybe (ModelConfig model) -> Value + +{- | Compute a canonical cache key from a model identity and complete input messages. + +The key includes all fields of each t'Message', so multi-modal content and +tool calls cannot collide with text-only requests. +-} +computeCacheKey :: + (CacheableChatModel model) => model -> Maybe (ModelConfig model) -> [Message] -> Text +computeCacheKey model cfg msgs = + toJsonText $ + object + [ "model" .= cacheModelIdentity model cfg + , "messages" .= msgs + ] + +instance (CacheableChatModel model, CacheBackend cache) => ChatModel (CachedModel model cache) where + type ModelConfig (CachedModel model cache) = ModelConfig model + + invoke CachedModel {..} msgs mbCfg = do + let key = computeCacheKey underlyingModel mbCfg msgs + mbCached <- getCache modelCache key + case mbCached of + Just cachedMsg -> pure cachedMsg + Nothing -> do + freshMsg <- invoke underlyingModel msgs mbCfg + putCache modelCache key freshMsg + pure freshMsg + + stream CachedModel {..} = + stream underlyingModel + +-- | Delegate tool binding to the underlying model +instance + (CacheableChatModel model, CacheBackend cache, ToolBinder model m) => + ToolBinder (CachedModel model cache) m + where + bindToolsConfig = bindToolsConfig @model diff --git a/src/Langchain/Callback.hs b/src/Langchain/Callback.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Callback.hs @@ -0,0 +1,15 @@ +{- | +Module : Langchain.Callback +Description : Typed event-driven callback system +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Typed event-driven callback system with synchronous and asynchronous dispatch. +-} +module Langchain.Callback + ( module Langchain.Callback.Manager + ) where + +import Langchain.Callback.Manager diff --git a/src/Langchain/Callback/Manager.hs b/src/Langchain/Callback/Manager.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Callback/Manager.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.Callback.Manager +Description : Typed event-driven callback system with synchronous and asynchronous dispatch +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Provides typed callback lifecycle events across models, tools, chains, and state graphs, +with support for filtering and non-blocking asynchronous event dispatch. +-} +module Langchain.Callback.Manager + ( CallbackEvent (..) + , CallbackHandler (..) + , CallbackManager (..) + , newCallbackManager + , registerHandler + , dispatchEvent + , dispatchEventAsync + , newLoggingCallbackHandler + , getCallbackLogs + ) where + +import Control.Concurrent.Async (async) +import Control.Concurrent.STM +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (FromJSON, ToJSON, Value) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime) +import GHC.Generics (Generic) + +-- | Comprehensive lifecycle events emitted across Langchain components +data CallbackEvent + = OnLLMStart !Text ![Text] !UTCTime -- Model name, Prompt inputs, Timestamp + | OnLLMEnd !Text !Text !Int !UTCTime -- Model name, Output text, Latency micros, Timestamp + | OnToolStart !Text !Value !UTCTime -- Tool name, Arguments, Timestamp + | OnToolEnd !Text !Text !Int !UTCTime -- Tool name, Output text, Latency micros, Timestamp + | OnRetrieverStart !Text !Text !UTCTime -- Retriever name, Query, Timestamp + | OnRetrieverEnd !Text ![Text] !Int !UTCTime -- Retriever name, Retrieved snippets, Latency micros, Timestamp + | OnChainStart !Text !Text !UTCTime -- Chain name, Input, Timestamp + | OnChainEnd !Text !Text !Int !UTCTime -- Chain name, Output, Latency micros, Timestamp + | OnGraphNodeStart !Text !Text !UTCTime -- NodeId, State summary, Timestamp + | OnGraphNodeEnd !Text !Text !Int !UTCTime -- NodeId, Next node/state summary, Latency micros, Timestamp + | OnError !Text !Text !UTCTime -- Component name, Error message, Timestamp + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | Handler for processing emitted callback events +data CallbackHandler = CallbackHandler + { handlerName :: !Text + , handleEvent :: CallbackEvent -> IO () + } + +-- | Thread-safe CallbackManager backed by STM TVar +newtype CallbackManager = CallbackManager + { handlersVar :: TVar [CallbackHandler] + } + +-- | Construct an empty CallbackManager +newCallbackManager :: MonadIO m => m CallbackManager +newCallbackManager = liftIO $ do + var <- newTVarIO [] + pure $ CallbackManager var + +-- | Register a new callback handler +registerHandler :: MonadIO m => CallbackManager -> CallbackHandler -> m () +registerHandler CallbackManager {..} handler = liftIO $ do + atomically $ modifyTVar' handlersVar (\handlers -> handlers ++ [handler]) + +-- | Dispatch an event synchronously to all registered handlers +dispatchEvent :: MonadIO m => CallbackManager -> CallbackEvent -> m () +dispatchEvent CallbackManager {..} event = liftIO $ do + handlers <- readTVarIO handlersVar + mapM_ (`handleEvent` event) handlers + +-- | Dispatch an event asynchronously in background threads without blocking +dispatchEventAsync :: MonadIO m => CallbackManager -> CallbackEvent -> m () +dispatchEventAsync CallbackManager {..} event = liftIO $ do + handlers <- readTVarIO handlersVar + mapM_ (\h -> async (handleEvent h event)) handlers + +-- | Create a simple callback handler that logs event descriptions into an STM TVar +newLoggingCallbackHandler :: MonadIO m => Text -> m (CallbackHandler, TVar [Text]) +newLoggingCallbackHandler name = liftIO $ do + logsVar <- newTVarIO [] + let handler = + CallbackHandler + { handlerName = name + , handleEvent = \event -> atomically $ modifyTVar' logsVar (\logs -> logs ++ [T.pack (show event)]) + } + pure (handler, logsVar) + +-- | Read all logs accumulated by a logging callback handler +getCallbackLogs :: MonadIO m => TVar [Text] -> m [Text] +getCallbackLogs = liftIO . readTVarIO diff --git a/src/Langchain/Chain.hs b/src/Langchain/Chain.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Chain.hs @@ -0,0 +1,15 @@ +{- | +Module : Langchain.Chain +Description : LLM chains +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Chains combining retrieval, prompt templates, and chat models. +-} +module Langchain.Chain + ( module Langchain.Chain.RetrievalQA + ) where + +import Langchain.Chain.RetrievalQA diff --git a/src/Langchain/Chain/RetrievalQA.hs b/src/Langchain/Chain/RetrievalQA.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Chain/RetrievalQA.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.Chain.RetrievalQA +Description : Effect-polymorphic RetrievalQA chain +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +RetrievalQA chain combining retriever search, context assembly, prompt rendering, +and ChatModel question answering. +-} +module Langchain.Chain.RetrievalQA + ( RetrievalQA (..) + , newRetrievalQA + , defaultQAPrompt + , runRetrievalQA + ) where + +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.IO.Class (MonadIO) +import Data.Map.Strict (fromList) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +import Langchain.DocumentLoader.Core (Document (..)) +import Langchain.Error (LangchainError) +import Langchain.Model + ( ChatModel (..) + , Message + , systemMessage + , userMessage + ) +import Langchain.PromptTemplate.Prompt (PromptTemplate, fromTemplate, renderPrompt) +import Langchain.Retriever.Core (Retriever (..)) + +-- | QA Chain configuration combining retrieval and LLM response generation. +data RetrievalQA model retriever = RetrievalQA + { model :: model + , retriever :: retriever + , prompt :: PromptTemplate + } + +-- | Construct a new RetrievalQA chain with default prompt +newRetrievalQA :: model -> retriever -> RetrievalQA model retriever +newRetrievalQA m r = RetrievalQA m r defaultQAPrompt + +-- | Default QA prompt template +defaultQAPrompt :: PromptTemplate +defaultQAPrompt = + fromTemplate + ( "Use the following pieces of context to answer the question at the end.\n" + <> "If you don't know the answer, just say that you don't know, don't try to make up an answer.\n\n" + <> "Context:\n{context}" + ) + +-- | Execute RetrievalQA chain on a user question +runRetrievalQA :: + (ChatModel model, Retriever retriever, MonadIO m, MonadError LangchainError m) => + RetrievalQA model retriever -> + Text -> + m Message +runRetrievalQA RetrievalQA {..} question = do + docs <- getRelevantDocuments retriever question + let contextText = T.intercalate "\n\n" $ map (TL.toStrict . pageContent) docs + vars = fromList [("context", contextText)] + renderedPrompt <- case renderPrompt prompt vars of + Left err -> throwError err + Right p -> pure p + let conversation = [systemMessage renderedPrompt, userMessage question] + invoke model conversation Nothing diff --git a/src/Langchain/Core/Error.hs b/src/Langchain/Core/Error.hs deleted file mode 100644 --- a/src/Langchain/Core/Error.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -{- | -Module : Langchain.Core.Error -Description : Core structured error types and context metadata -Copyright : (c) 2025-2026 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental - -Structured error handling without String-based error dropping. --} -module Langchain.Core.Error - ( LangchainError (..) - , ErrorContext (..) - , LangchainResult - , errorMessage - , mkContext - , mkContextIO - , llmError - , agentError - , memoryError - , toolError - , vectorStoreError - , documentLoaderError - , embeddingError - , runnableError - , parsingError - , networkError - , configurationError - , validationError - , internalError - ) where - -import Control.DeepSeq (NFData) -import Control.Exception (Exception (..)) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Aeson (FromJSON, ToJSON) -import Data.Map (Map) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time (UTCTime, getCurrentTime) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import GHC.Generics (Generic) - --- | Detailed context metadata attached to every error. -data ErrorContext = ErrorContext - { component :: Text - , operation :: Text - , timestamp :: UTCTime - , details :: Map Text Text - } - deriving (Show, Eq, Generic, ToJSON, FromJSON, NFData) - --- | Pure context constructor. -mkContext :: Text -> Text -> Map Text Text -> ErrorContext -mkContext comp op = ErrorContext comp op (posixSecondsToUTCTime 0) - --- | IO context constructor with real timestamp. -mkContextIO :: MonadIO m => Text -> Text -> Map Text Text -> m ErrorContext -mkContextIO comp op dt = do - now <- liftIO getCurrentTime - pure $ ErrorContext comp op now dt - --- | Core framework error type. -data LangchainError - = LLMError Text (Maybe ErrorContext) - | AgentError Text (Maybe ErrorContext) - | MemoryError Text (Maybe ErrorContext) - | ToolError Text (Maybe ErrorContext) - | VectorStoreError Text (Maybe ErrorContext) - | DocumentLoaderError Text (Maybe ErrorContext) - | EmbeddingError Text (Maybe ErrorContext) - | RunnableError Text (Maybe ErrorContext) - | ParsingError Text (Maybe ErrorContext) - | NetworkError Text (Maybe ErrorContext) - | ConfigurationError Text (Maybe ErrorContext) - | ValidationError Text (Maybe ErrorContext) - | InternalError Text (Maybe ErrorContext) - deriving (Show, Eq, Generic, ToJSON, FromJSON, NFData) - --- | Type alias for Either LangchainError a -type LangchainResult a = Either LangchainError a - --- | Extract human-readable error message text from a LangchainError -errorMessage :: LangchainError -> Text -errorMessage (LLMError msg _) = msg -errorMessage (AgentError msg _) = msg -errorMessage (MemoryError msg _) = msg -errorMessage (ToolError msg _) = msg -errorMessage (VectorStoreError msg _) = msg -errorMessage (DocumentLoaderError msg _) = msg -errorMessage (EmbeddingError msg _) = msg -errorMessage (RunnableError msg _) = msg -errorMessage (ParsingError msg _) = msg -errorMessage (NetworkError msg _) = msg -errorMessage (ConfigurationError msg _) = msg -errorMessage (ValidationError msg _) = msg -errorMessage (InternalError msg _) = msg - -instance Exception LangchainError where - displayException err = case err of - LLMError msg ctx -> formatError "LLMError" msg ctx - AgentError msg ctx -> formatError "AgentError" msg ctx - MemoryError msg ctx -> formatError "MemoryError" msg ctx - ToolError msg ctx -> formatError "ToolError" msg ctx - VectorStoreError msg ctx -> formatError "VectorStoreError" msg ctx - DocumentLoaderError msg ctx -> formatError "DocumentLoaderError" msg ctx - EmbeddingError msg ctx -> formatError "EmbeddingError" msg ctx - RunnableError msg ctx -> formatError "RunnableError" msg ctx - ParsingError msg ctx -> formatError "ParsingError" msg ctx - NetworkError msg ctx -> formatError "NetworkError" msg ctx - ConfigurationError msg ctx -> formatError "ConfigurationError" msg ctx - ValidationError msg ctx -> formatError "ValidationError" msg ctx - InternalError msg ctx -> formatError "InternalError" msg ctx - where - formatError errType msg Nothing = errType ++ ": " ++ T.unpack msg - formatError errType msg (Just ctx) = - errType - ++ ": " - ++ T.unpack msg - ++ " [Component: " - ++ T.unpack (component ctx) - ++ ", Operation: " - ++ T.unpack (operation ctx) - ++ "]" - --- | Helper constructors -mkErrorCtx :: - (Text -> Maybe ErrorContext -> LangchainError) -> Text -> Maybe Text -> Maybe Text -> LangchainError -mkErrorCtx ctor msg mbComp mbOp = - let mbCtx = case (mbComp, mbOp) of - (Nothing, Nothing) -> Nothing - (Just c, Just o) -> Just $ mkContext c o mempty - (Just c, Nothing) -> Just $ mkContext c "unspecified" mempty - (Nothing, Just o) -> Just $ mkContext "unspecified" o mempty - in ctor msg mbCtx - -llmError :: Text -> Maybe Text -> Maybe Text -> LangchainError -llmError = mkErrorCtx LLMError - -agentError :: Text -> Maybe Text -> Maybe Text -> LangchainError -agentError = mkErrorCtx AgentError - -memoryError :: Text -> Maybe Text -> Maybe Text -> LangchainError -memoryError = mkErrorCtx MemoryError - -toolError :: Text -> Maybe Text -> Maybe Text -> LangchainError -toolError = mkErrorCtx ToolError - -vectorStoreError :: Text -> Maybe Text -> Maybe Text -> LangchainError -vectorStoreError = mkErrorCtx VectorStoreError - -documentLoaderError :: Text -> Maybe Text -> Maybe Text -> LangchainError -documentLoaderError = mkErrorCtx DocumentLoaderError - -embeddingError :: Text -> Maybe Text -> Maybe Text -> LangchainError -embeddingError = mkErrorCtx EmbeddingError - -runnableError :: Text -> Maybe Text -> Maybe Text -> LangchainError -runnableError = mkErrorCtx RunnableError - -parsingError :: Text -> Maybe Text -> Maybe Text -> LangchainError -parsingError = mkErrorCtx ParsingError - -networkError :: Text -> Maybe Text -> Maybe Text -> LangchainError -networkError = mkErrorCtx NetworkError - -configurationError :: Text -> Maybe Text -> Maybe Text -> LangchainError -configurationError = mkErrorCtx ConfigurationError - -validationError :: Text -> Maybe Text -> Maybe Text -> LangchainError -validationError = mkErrorCtx ValidationError - -internalError :: Text -> Maybe Text -> Maybe Text -> LangchainError -internalError = mkErrorCtx InternalError diff --git a/src/Langchain/Core/Model.hs b/src/Langchain/Core/Model.hs deleted file mode 100644 --- a/src/Langchain/Core/Model.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -{- | -Module : Langchain.Core.Model -Description : Central ChatModel typeclass for LLM providers -Copyright : (c) 2025-2026 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental - -Provides effect-polymorphic 'ChatModel' interface. --} -module Langchain.Core.Model - ( ChatModel (..) - , module Langchain.Core.Model.Types - ) where - -import Control.Monad.Except (MonadError) -import Control.Monad.IO.Class (MonadIO) -import Data.Kind (Type) - -import Langchain.Core.Error (LangchainError) -import Langchain.Core.Model.Types -import Langchain.Core.Stream (ChatStream) - --- | Effect-polymorphic ChatModel typeclass for LLM providers -class ChatModel model where - type ModelConfig model :: Type - - -- | Single synchronous invocation - invoke :: - (MonadIO m, MonadError LangchainError m) => - model -> - [Message] -> - Maybe (ModelConfig model) -> - m Message - - -- | Batch invocations (default: sequential) - batch :: - (MonadIO m, MonadError LangchainError m) => - model -> - [[Message]] -> - Maybe (ModelConfig model) -> - m [Message] - batch model msgs cfg = mapM (\m -> invoke model m cfg) msgs - - -- | Streaming invocation yielding structured StreamEvents via Conduit - stream :: - model -> - [Message] -> - Maybe (ModelConfig model) -> - ChatStream diff --git a/src/Langchain/Core/Model/Types.hs b/src/Langchain/Core/Model/Types.hs deleted file mode 100644 --- a/src/Langchain/Core/Model/Types.hs +++ /dev/null @@ -1,199 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-partial-fields #-} - -{- | -Module : Langchain.Core.Model.Types -Description : Multi-modal ContentBlock and Message data types -Copyright : (c) 2025-2026 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental - -Data types for multi-modal messages, content blocks, roles, and tool calls. --} -module Langchain.Core.Model.Types - ( ContentBlock (..) - , ImageContent (..) - , ImageSource (..) - , Role (..) - , ToolCall (..) - , Message (..) - , textMessage - , userMessage - , systemMessage - , assistantMessage - , toolMessage - , imageMessage - , extractMessageText - , roleLabel - , formatMessageString - ) where - -import Control.DeepSeq (NFData) -import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, withObject, (.:), (.:?), (.=)) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Base64 as Base64 -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import GHC.Generics (Generic) - --- | A single content block within a multi-modal message. -data ContentBlock - = TextBlock {blockText :: Text} - | ImageBlock ImageContent - | AudioBlock {blockMimeType :: Text, blockBase64 :: Text} - | DataBlock {blockBytes :: ByteString} - deriving (Eq, Show, Generic, NFData) - -data ImageContent = ImageContent - { imageSource :: ImageSource - , imageDetail :: Maybe Text - , imageMetadata :: Maybe Value - } - deriving (Eq, Show, Generic, NFData) - -data ImageSource - = ImageBase64 {imageMimeType :: Maybe Text, imageData :: Text} - | ImageUrl {imageUrl :: Text} - deriving (Eq, Show, Generic, NFData) - -instance ToJSON ContentBlock where - toJSON (TextBlock t) = object ["type" .= ("text" :: Text), "text" .= t] - toJSON (ImageBlock ImageContent {imageSource = ImageUrl url, imageDetail = detail}) = - object - [ "type" .= ("image_url" :: Text) - , "image_url" .= object (maybe id ((:) . ("detail" .=)) detail ["url" .= url]) - ] - toJSON (ImageBlock ImageContent {imageSource = ImageBase64 (Just mime) imageData, imageMetadata = metadata}) = - object $ - ["type" .= ("image" :: Text), "mime_type" .= mime, "data" .= imageData] - <> maybe [] (pure . ("metadata" .=)) metadata - toJSON (ImageBlock ImageContent {imageSource = ImageBase64 _ imageData, imageMetadata = metadata}) = - object $ - ["type" .= ("image" :: Text), "source_type" .= ("base64" :: Text), "data" .= imageData] - <> maybe [] (pure . ("metadata" .=)) metadata - toJSON (AudioBlock mime b64) = object ["type" .= ("audio" :: Text), "mime_type" .= mime, "data" .= b64] - toJSON (DataBlock bs) = object ["type" .= ("data" :: Text), "data" .= TE.decodeUtf8 (Base64.encode bs)] - -instance FromJSON ContentBlock where - parseJSON = withObject "ContentBlock" $ \v -> do - typ <- v .: "type" - case (typ :: Text) of - "text" -> TextBlock <$> v .: "text" - "image" -> do - mimeType <- v .:? "mime_type" - case mimeType of - Just mime -> do - imageData <- v .: "data" - metadata <- v .:? "metadata" - pure $ ImageBlock $ ImageContent (ImageBase64 (Just mime) imageData) Nothing metadata - Nothing -> do - sourceType <- v .: "source_type" - imageData <- v .: "data" - metadata <- v .:? "metadata" - let source = - case (sourceType :: Text) of - "url" -> ImageUrl imageData - _ -> ImageBase64 Nothing imageData - pure $ ImageBlock $ ImageContent source Nothing metadata - "image_url" -> do - imageUrl <- v .: "image_url" - url <- imageUrl .: "url" - detail <- imageUrl .:? "detail" - pure $ ImageBlock $ ImageContent (ImageUrl url) detail Nothing - "audio" -> AudioBlock <$> v .: "mime_type" <*> v .: "data" - "data" -> do - b64Text <- v .: "data" - case Base64.decode (TE.encodeUtf8 b64Text) of - Left err -> fail $ "Invalid base64 data block: " ++ err - Right bs -> pure $ DataBlock bs - other -> fail $ "Unknown ContentBlock type: " ++ show other - --- | Complete set of conversation roles supported across LLM providers. -data Role - = System - | User - | Assistant - | Tool - | Developer - | Function - deriving (Eq, Ord, Show, Bounded, Enum, Generic, ToJSON, FromJSON, NFData) - --- | Structured tool call from an LLM response. -data ToolCall = ToolCall - { toolCallId :: Text - , toolCallType :: Text - -- ^ Always "function" for current providers - , toolCallName :: Text - , toolCallArguments :: Value - -- ^ Parsed JSON Value arguments - } - deriving (Eq, Show, Generic, ToJSON, FromJSON, NFData) - --- | Structured chat message supporting multi-modal content blocks. -data Message = Message - { messageRole :: Role - , messageContents :: NonEmpty ContentBlock - , messageName :: Maybe Text - , messageToolCalls :: Maybe [ToolCall] - , messageToolId :: Maybe Text - -- ^ Associated tool call ID for Tool role - , messageMetadata :: Map Text Value - -- ^ Opaque provider-specific metadata. - } - deriving (Eq, Show, Generic, ToJSON, FromJSON, NFData) - --- | Create a message with a single text content block. -textMessage :: Role -> Text -> Message -textMessage r t = Message r (TextBlock t :| []) Nothing Nothing Nothing Map.empty - --- | Create a User role text message. -userMessage :: Text -> Message -userMessage = textMessage User - --- | Create a System role text message. -systemMessage :: Text -> Message -systemMessage = textMessage System - --- | Create an Assistant role text message. -assistantMessage :: Text -> Message -assistantMessage = textMessage Assistant - --- | Create a Tool role text message. -toolMessage :: Text -> Message -toolMessage = textMessage Tool - --- | Create an Image content block message. -imageMessage :: Role -> Text -> Text -> Message -imageMessage r mime b64 = - Message - r - (ImageBlock (ImageContent (ImageBase64 (Just mime) b64) Nothing Nothing) :| []) - Nothing - Nothing - Nothing - Map.empty - --- | Extract all text content blocks concatenated into a single Text string. -extractMessageText :: Message -> Text -extractMessageText msg = T.intercalate "\n" [t | TextBlock t <- NonEmpty.toList (messageContents msg)] - --- | Label used when rendering a chat message role as plain text. -roleLabel :: Role -> Text -roleLabel System = "System" -roleLabel User = "Human" -roleLabel Assistant = "AI" -roleLabel Tool = "Tool" -roleLabel Developer = "Developer" -roleLabel Function = "Function" - --- | Render a message as a single plain-text line with its role label. -formatMessageString :: Message -> Text -formatMessageString chatMessage = - roleLabel (messageRole chatMessage) <> ": " <> extractMessageText chatMessage diff --git a/src/Langchain/Core/Monad.hs b/src/Langchain/Core/Monad.hs deleted file mode 100644 --- a/src/Langchain/Core/Monad.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -{- | -Module : Langchain.Core.Monad -Description : Core LangchainT monad transformer -Copyright : (c) 2025-2026 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental - -Provides the canonical monad transformer stack 'LangchainT' and its execution -runner 'runLangchainT'. - -'LangchainT' is parameterised over the reader environment @r@, so each -provider (or application) can supply its own config type rather than being -forced into a one-size-fits-all 'LangchainConfig'. Use @r = ()@ when you do -not need a shared environment at all. - -@ --- With a custom config -type App a = LangchainT MyConfig IO a - -runApp :: MyConfig -> App a -> IO (Either LangchainError a) -runApp = runLangchainT - --- Without any config -runSimple :: LangchainT () IO a -> IO (Either LangchainError a) -runSimple = runLangchainT () -@ --} -module Langchain.Core.Monad - ( LangchainT - , runLangchainT - , throwLangchainError - ) where - -import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError) -import Control.Monad.Reader (ReaderT, runReaderT) - -import Langchain.Core.Error (LangchainError) - -{- | Standard framework monad transformer stack: ReaderT over ExceptT. - -The type variable @r@ is the reader environment — pass your own provider -config, application context, or @()@ when none is needed. --} -type LangchainT r m = ReaderT r (ExceptT LangchainError m) - --- | Execute a 'LangchainT' computation with a given environment. -runLangchainT :: r -> LangchainT r m a -> m (Either LangchainError a) -runLangchainT env action = runExceptT (runReaderT action env) - --- | Throw a 'LangchainError' inside any 'MonadError' context. -throwLangchainError :: MonadError LangchainError m => LangchainError -> m a -throwLangchainError = throwError diff --git a/src/Langchain/Core/Runnable.hs b/src/Langchain/Core/Runnable.hs deleted file mode 100644 --- a/src/Langchain/Core/Runnable.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} - -{- | -Module : Langchain.Core.Runnable -Description : Pure pipeline GADT (RunnableTree) and algebraic composition -Copyright : (c) 2025-2026 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental - -Pure, AST-based pipeline representation ('RunnableTree') where building pipelines performs -NO side effects. Execution is strictly deferred to 'interpret'. --} -module Langchain.Core.Runnable - ( Runnable (..) - , RunnableTree (..) - , (|>>) - , (&>&) - , interpret - , runLambda - , runPrim - , runPure - , runPassthrough - , runIdent - , runBranch - , runFallback - , runChat - , runModel - , ModelRunnable (..) - , TextModelRunnable (..) - ) where - -import Control.Concurrent.Async (concurrently) -import Control.Monad.Except (ExceptT, MonadError, catchError, runExceptT, throwError) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Aeson (Value) -import Data.Kind (Type) -import Data.Text (Text) - -import Langchain.Core.Error (LangchainError) -import Langchain.Core.Model (ChatModel, extractMessageText, userMessage) -import qualified Langchain.Core.Model as M (invoke) -import Langchain.Core.Model.Types (Message) -import Langchain.Core.Tool (Tool (..)) - --- | Fundamental Runnable interface for components wrapped in 'Prim'. -class Runnable r m where - type RunnableInput r :: Type - type RunnableOutput r :: Type - invoke :: r -> RunnableInput r -> m (Either LangchainError (RunnableOutput r)) - --- | Any Tool can be executed as a primitive Runnable taking JSON 'Value' to 'Text'. -instance Monad m => Runnable (Tool m) m where - type RunnableInput (Tool m) = Value - type RunnableOutput (Tool m) = Text - invoke = toolExecute - --- | Wrapper to treat any 'ChatModel' as a Runnable over '[Message]' -> 'Message'. -newtype ModelRunnable c = ModelRunnable c - deriving (Eq, Show) - -instance (ChatModel c, MonadIO m) => Runnable (ModelRunnable c) m where - type RunnableInput (ModelRunnable c) = [Message] - type RunnableOutput (ModelRunnable c) = Message - invoke (ModelRunnable c) msgs = runExceptT (M.invoke c msgs Nothing) - --- | Wrapper to treat any 'ChatModel' as a simple 'Text' -> 'Text' Runnable. -newtype TextModelRunnable c = TextModelRunnable c - deriving (Eq, Show) - -instance (ChatModel c, MonadIO m) => Runnable (TextModelRunnable c) m where - type RunnableInput (TextModelRunnable c) = Text - type RunnableOutput (TextModelRunnable c) = Text - invoke (TextModelRunnable c) prompt = do - res <- runExceptT $ M.invoke c [userMessage prompt] Nothing - pure (extractMessageText <$> res) - -{- | Pure GADT representing a composable pipeline AST. -'i' = input type, 'o' = output type, 'm' = monad context. --} -data RunnableTree m i o where - -- | Identity: passes input through unchanged - Id :: RunnableTree m a a - -- | Lift a component implementing Runnable into the tree - Prim :: - (Runnable r m, RunnableInput r ~ i, RunnableOutput r ~ o) => - r -> - RunnableTree m i o - -- | Lift a monadic function into the tree - Lambda :: (i -> m (Either LangchainError o)) -> RunnableTree m i o - -- | Sequential composition AST node - Seq :: RunnableTree m i mid -> RunnableTree m mid o -> RunnableTree m i o - -- | Parallel composition AST node - Par :: - RunnableTree (ExceptT LangchainError IO) i o1 -> - RunnableTree (ExceptT LangchainError IO) i o2 -> - RunnableTree (ExceptT LangchainError IO) i (o1, o2) - -- | Conditional branching AST node - Branch :: - (i -> m Bool) -> - -- | True branch - RunnableTree m i o -> - -- | False branch - RunnableTree m i o -> - RunnableTree m i o - -- | Fallback node: if primary fails, executes fallback - Fallback :: RunnableTree m i o -> RunnableTree m i o -> RunnableTree m i o - --- | Sequential composition operator — PURE AST builder. -(|>>) :: RunnableTree m a b -> RunnableTree m b c -> RunnableTree m a c -(|>>) = Seq - -infixl 1 |>> - --- | Parallel composition operator — PURE AST builder. -(&>&) :: - RunnableTree (ExceptT LangchainError IO) a b -> - RunnableTree (ExceptT LangchainError IO) a c -> - RunnableTree (ExceptT LangchainError IO) a (b, c) -(&>&) = Par - -infixl 2 &>& - --- | Helper to create a lambda runnable node. -runLambda :: (i -> m (Either LangchainError o)) -> RunnableTree m i o -runLambda = Lambda - --- | Helper to create a primitive runnable node. -runPrim :: - (Runnable r m, RunnableInput r ~ i, RunnableOutput r ~ o) => - r -> - RunnableTree m i o -runPrim = Prim - --- | Helper to convert Either to MonadError -liftEither :: MonadError LangchainError m => Either LangchainError a -> m a -liftEither (Left err) = throwError err -liftEither (Right x) = pure x - --- | Sole execution engine for 'RunnableTree' AST pipelines. -interpret :: - (MonadIO m, MonadError LangchainError m) => - RunnableTree m i o -> - i -> - m o -interpret Id input = pure input -interpret (Prim r) input = invoke r input >>= liftEither -interpret (Lambda f) input = f input >>= liftEither -interpret (Seq t1 t2) input = interpret t1 input >>= interpret t2 -interpret (Par t1 t2) input = do - (r1, r2) <- - liftIO $ - concurrently - (runExceptT $ interpret t1 input) - (runExceptT $ interpret t2 input) - o1 <- liftEither r1 - o2 <- liftEither r2 - pure (o1, o2) -interpret (Branch cond tTrue tFalse) input = do - b <- cond input - if b then interpret tTrue input else interpret tFalse input -interpret (Fallback t1 t2) input = - catchError (interpret t1 input) (\_ -> interpret t2 input) - --- | Lift a pure function into a 'RunnableTree' node. -runPure :: Monad m => (i -> o) -> RunnableTree m i o -runPure f = runLambda (pure . Right . f) - --- | Identity node in a 'RunnableTree' (passes input through unchanged, like LangChain's 'RunnablePassthrough'). -runPassthrough :: RunnableTree m a a -runPassthrough = Id - --- | Alias for 'runPassthrough'. -runIdent :: RunnableTree m a a -runIdent = Id - --- | Construct a conditional branch AST node. -runBranch :: (i -> m Bool) -> RunnableTree m i o -> RunnableTree m i o -> RunnableTree m i o -runBranch = Branch - --- | Construct a self-healing fallback AST node (tries first, catches errors and runs second). -runFallback :: RunnableTree m i o -> RunnableTree m i o -> RunnableTree m i o -runFallback = Fallback - --- | Lift any 'ChatModel' into a simple 'Text' -> 'Text' pipeline step. -runChat :: (ChatModel c, MonadIO m) => c -> RunnableTree m Text Text -runChat c = runPrim (TextModelRunnable c) - --- | Lift any 'ChatModel' into a structured '[Message]' -> 'Message' pipeline step. -runModel :: (ChatModel c, MonadIO m) => c -> RunnableTree m [Message] Message -runModel c = runPrim (ModelRunnable c) diff --git a/src/Langchain/Core/Stream.hs b/src/Langchain/Core/Stream.hs deleted file mode 100644 --- a/src/Langchain/Core/Stream.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# OPTIONS_GHC -Wno-partial-fields #-} - -{- | -Module : Langchain.Core.Stream -Description : Standardized StreamEvent protocol and utilities -Copyright : (c) 2025-2026 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental - -Structured streaming event protocol for tracking LLM, tool, chain, and graph lifecycle events. --} -module Langchain.Core.Stream - ( TokenUsage (..) - , StreamEvent (..) - , StreamM - , EventStream - , ChatStream - , StreamCallback - , StreamSource - , callbackSource - , collectEvents - , printEvents - ) where - -import Control.Concurrent.Async (async, cancel) -import Control.Concurrent.STM - ( atomically - , newEmptyTMVarIO - , newTBQueueIO - , orElse - , putTMVar - , readTBQueue - , readTMVar - , writeTBQueue - ) -import Control.Exception (finally) -import Control.Monad.Except (ExceptT, runExceptT) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Resource (ResourceT, runResourceT) -import Data.Aeson (FromJSON, ToJSON, Value) -import Data.Conduit (ConduitT, bracketP, runConduit, yield, (.|)) -import qualified Data.Conduit.List as CL -import Data.Text (Text) -import GHC.Generics (Generic) -import Langchain.Core.Error (LangchainError) -import Langchain.Core.Model.Types (Message, ToolCall) - --- | Token usage accounting for LLM execution. -data TokenUsage = TokenUsage - { promptTokens :: Int - , completionTokens :: Int - , totalTokens :: Int - } - deriving (Eq, Show, Generic, ToJSON, FromJSON) - -{- | All streaming events emitted across the framework execution lifecycle. -Every event carries a 'runId' for correlation. --} -data StreamEvent - = -- | LLM lifecycle start - LLMStart - { runId :: Text - , modelName :: Text - , inputMessages :: [Message] - } - | -- | LLM incremental streaming chunk - LLMChunk - { runId :: Text - , chunkText :: Text - , toolCallDelta :: Maybe ToolCall - } - | -- | LLM lifecycle completion - LLMEnd - { runId :: Text - , finalMessage :: Message - , tokenUsage :: Maybe TokenUsage - } - | -- | Tool execution start - ToolStart - { runId :: Text - , toolName :: Text - , toolInput :: Value - } - | -- | Tool execution completion - ToolEnd - { runId :: Text - , toolName :: Text - , toolOutput :: Value - } - | -- | Tool execution failure - ToolErrorEvent - { runId :: Text - , toolName :: Text - , toolErrorPayload :: LangchainError - } - | -- | Chain execution start - ChainStart - { runId :: Text - , chainName :: Text - , chainInput :: Value - } - | -- | Chain execution completion - ChainEnd - { runId :: Text - , chainName :: Text - , chainOutput :: Value - } - | -- | Graph node execution start - NodeStart - { runId :: Text - , nodeId :: Text - , nodeState :: Value - } - | -- | Graph node execution completion - NodeEnd - { runId :: Text - , nodeId :: Text - , nodeState :: Value - } - deriving (Eq, Show, Generic, ToJSON, FromJSON) - --- | Canonical event stream type using Conduit. -type EventStream m = ConduitT () StreamEvent m () - --- | Effects used by resource-safe chat model streams. -type StreamM = ExceptT LangchainError (ResourceT IO) - --- | A resource-safe stream of chat model events. -type ChatStream = EventStream StreamM - --- | A callback function that produces values of type @a@. -type StreamCallback a = (a -> IO ()) -> IO () - --- | A Conduit source that produces values of type @a@ in the 'StreamM' monad. -type StreamSource a = ConduitT () a StreamM () - --- | Convert a callback-based streaming function into a Conduit source. -callbackSource :: StreamCallback a -> StreamSource a -callbackSource produce = bracketP start (cancel . third) consume - where - start = do - queue <- newTBQueueIO 64 - finished <- newEmptyTMVarIO - worker <- - async $ produce (atomically . writeTBQueue queue) `finally` atomically (putTMVar finished ()) - pure (queue, finished, worker) - - consume (queue, finished, _worker) = loop - where - loop = do - let waitForFinished = Nothing <$ readTMVar finished - readEvent = Just <$> readTBQueue queue - next <- liftIO . atomically $ readEvent `orElse` waitForFinished - case next of - Just item -> yield item >> loop - Nothing -> pure () - - third (_, _, worker) = worker - --- | Collect all emitted events from a stream into a list. -collectEvents :: Monad m => EventStream m -> m [StreamEvent] -collectEvents streamSrc = runConduit (streamSrc .| CL.consume) - --- | Debug helper: print all stream events to stdout. -printEvents :: EventStream (ExceptT LangchainError (ResourceT IO)) -> IO (Either LangchainError ()) -printEvents streamSrc = runResourceT $ runExceptT $ runConduit (streamSrc .| CL.mapM_ (liftIO . print)) diff --git a/src/Langchain/Core/Tool.hs b/src/Langchain/Core/Tool.hs deleted file mode 100644 --- a/src/Langchain/Core/Tool.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{- | -Module : Langchain.Core.Tool -Description : Effect-polymorphic Tool specification and parameter validation -Copyright : (c) 2025-2026 Tushar Adhatrao -License : MIT -Maintainer : Tushar Adhatrao -Stability : experimental - -Provides effect-polymorphic 'Tool m' representation, schema generation, and argument parsing. --} -module Langchain.Core.Tool - ( Tool (..) - , createTool - , toolToValue - ) where - -import Data.Aeson -import Data.Text (Text) - -import Langchain.Core.Error (LangchainError) - --- | Effect-polymorphic Tool abstraction -data Tool m = Tool - { toolName :: Text - -- ^ Unique identifier for the tool - , toolDescription :: Text - -- ^ Description explaining when and how to use the tool - , toolSchema :: Value - -- ^ JSON Schema describing expected parameters - , toolExecute :: Value -> m (Either LangchainError Text) - -- ^ Monadic execution function accepting JSON arguments and returning text output - } - -instance Show (Tool m) where - show t = "Tool { toolName = " ++ show (toolName t) ++ " }" - --- | Helper to create a Tool from a name, description, schema, and execution function -createTool :: - Text -> - Text -> - Value -> - (Value -> m (Either LangchainError Text)) -> - Tool m -createTool name desc schema execFn = - Tool - { toolName = name - , toolDescription = desc - , toolSchema = schema - , toolExecute = execFn - } - --- | Convert Tool definition to OpenAI/Ollama compatible function definition JSON object -toolToValue :: Tool m -> Value -toolToValue Tool {..} = - object - [ "type" .= ("function" :: Text) - , "function" - .= object - [ "name" .= toolName - , "description" .= toolDescription - , "parameters" .= toolSchema - ] - ] diff --git a/src/Langchain/DocumentLoader.hs b/src/Langchain/DocumentLoader.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/DocumentLoader.hs @@ -0,0 +1,17 @@ +{- | +Module : Langchain.DocumentLoader +Description : Document loading abstractions and standard implementations +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +-} +module Langchain.DocumentLoader + ( module Langchain.DocumentLoader.Core + , module Langchain.DocumentLoader.FileLoader + , module Langchain.DocumentLoader.DirectoryLoader + ) where + +import Langchain.DocumentLoader.Core +import Langchain.DocumentLoader.DirectoryLoader +import Langchain.DocumentLoader.FileLoader diff --git a/src/Langchain/DocumentLoader/Core.hs b/src/Langchain/DocumentLoader/Core.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/DocumentLoader/Core.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE FlexibleContexts #-} + +{- | +Module : Langchain.DocumentLoader.Core +Description : Core document loading functionality for LangChain Haskell +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Implementation of LangChain's document loading abstraction. +-} +module Langchain.DocumentLoader.Core + ( Document (..) + , BaseLoader (..) + , splitDocuments + ) where + +import Control.Monad.Except (MonadError) +import Control.Monad.IO.Class (MonadIO) +import Data.Aeson (Value) +import Data.Map (Map, empty) +import qualified Data.Text as TS +import Data.Text.Lazy (Text) + +import Langchain.Error (LangchainError) +import Langchain.TextSplitter.Character (defaultCharacterSplitterOps, splitText) + +-- | Document container with content and metadata +data Document = Document + { pageContent :: Text + -- ^ The text content of the document + , metadata :: Map TS.Text Value + -- ^ Additional metadata (e.g., source, page number) + } + deriving (Show, Eq) + +instance Semigroup Document where + doc1 <> doc2 = + Document + (pageContent doc1 <> pageContent doc2) + (metadata doc1 <> metadata doc2) + +instance Monoid Document where + mempty = Document mempty empty + +-- | Effect-polymorphic BaseLoader typeclass +class BaseLoader loader where + -- | Load all documents from the source + load :: + (MonadIO m, MonadError LangchainError m) => + loader -> + m [Document] + + -- | Load all documents and split their content into chunks using 'defaultCharacterSplitterOps'. + loadAndSplit :: + (MonadIO m, MonadError LangchainError m) => + loader -> + m [Text] + loadAndSplit loader = do + docs <- load loader + pure $ concatMap (splitText defaultCharacterSplitterOps . pageContent) docs + +{- | Split a list of documents using any text splitting function, preserving metadata on each chunk. + +Example: + +@ +chunks = splitDocuments (splitTextRecursive defaultRecursiveCharacterSplitterOps) docs +@ +-} +splitDocuments :: (Text -> [Text]) -> [Document] -> [Document] +splitDocuments splitFn docs = + [ Document chunk (metadata doc) + | doc <- docs + , chunk <- splitFn (pageContent doc) + ] diff --git a/src/Langchain/DocumentLoader/DirectoryLoader.hs b/src/Langchain/DocumentLoader/DirectoryLoader.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/DocumentLoader/DirectoryLoader.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.DocumentLoader.DirectoryLoader +Description : Directory loading implementation for LangChain Haskell +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +DirectoryLoader document loader reads files from disk into Documents. +-} +module Langchain.DocumentLoader.DirectoryLoader + ( DirectoryLoader (..) + , DirectoryLoaderOptions (..) + , defaultDirectoryLoaderOptions + ) where + +import Control.Concurrent.Async (mapConcurrently) +import Control.Monad (filterM, forM) +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (liftIO) +import Data.Maybe (listToMaybe) +import qualified Data.Text as T +import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) +import System.FilePath (takeExtension, takeFileName, ()) + +import Langchain.DocumentLoader.Core +import Langchain.DocumentLoader.FileLoader (FileLoader (FileLoader)) +import Langchain.Error (documentLoaderError) + +-- | Options for directory loading behavior +data DirectoryLoaderOptions = DirectoryLoaderOptions + { recursiveDepth :: Maybe Int + -- ^ Nothing = unlimited depth, Just 0 = No recursive, Just 3 = 3 level deep + , extensions :: [String] + -- ^ File extensions to include (e.g., [".txt", ".md"]) + , excludeHidden :: Bool + -- ^ Whether to exclude hidden files (starting with '.') + , useMultithreading :: Bool + -- ^ Whether to use multithreading when loading files + } + deriving (Eq, Show) + +-- | Default directory loader options +defaultDirectoryLoaderOptions :: DirectoryLoaderOptions +defaultDirectoryLoaderOptions = + DirectoryLoaderOptions + { recursiveDepth = Nothing + , extensions = [] + , excludeHidden = True + , useMultithreading = False + } + +-- | Directory loader configuration +data DirectoryLoader = DirectoryLoader + { dirPath :: FilePath + , directoryLoaderOptions :: DirectoryLoaderOptions + } + deriving (Eq, Show) + +-- | Helper to check if a file should be included based on options +shouldIncludeFile :: DirectoryLoaderOptions -> FilePath -> Bool +shouldIncludeFile opts path = + let ext = takeExtension path + fName = takeFileName path + isHidden = listToMaybe fName == Just '.' + matchesExt = null (extensions opts) || ext `elem` extensions opts + passesHiddenCheck = not (excludeHidden opts) || not isHidden + in matchesExt && passesHiddenCheck + +-- | Get all files in a directory, with controlled recursion +getFilesInDirectory :: DirectoryLoaderOptions -> Int -> FilePath -> IO [FilePath] +getFilesInDirectory opts currentDepth dir = do + let canRecurse = case recursiveDepth opts of + Nothing -> True + Just maxD -> currentDepth < maxD + + entries <- listDirectory dir + let fullPaths = map (dir ) entries + + files <- filterM doesFileExist fullPaths + let filteredFiles = filter (shouldIncludeFile opts) files + + subFiles <- + if canRecurse + then do + subdirs <- filterM doesDirectoryExist fullPaths + let visibleSubdirs = + if excludeHidden opts + then filter (\d -> not (null d) && listToMaybe d /= Just '.') subdirs + else subdirs + + if useMultithreading opts && not (null visibleSubdirs) + then + concat + <$> mapConcurrently + (getFilesInDirectory opts (currentDepth + 1)) + visibleSubdirs + else concat <$> mapM (getFilesInDirectory opts (currentDepth + 1)) visibleSubdirs + else pure [] + + pure $ filteredFiles ++ subFiles + +instance BaseLoader DirectoryLoader where + load DirectoryLoader {..} = do + exists <- liftIO $ doesDirectoryExist dirPath + if exists + then do + filePaths <- liftIO $ getFilesInDirectory directoryLoaderOptions 0 dirPath + fmap concat $ forM filePaths $ \path -> + load (FileLoader path) + else + throwError $ + documentLoaderError + (T.pack $ "Directory does not exist: " ++ dirPath) + (Just "DirectoryLoader") + (Just $ T.pack dirPath) diff --git a/src/Langchain/DocumentLoader/FileLoader.hs b/src/Langchain/DocumentLoader/FileLoader.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/DocumentLoader/FileLoader.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Langchain.DocumentLoader.FileLoader +Description : File loading implementation for LangChain Haskell +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +File-based document loader implementation following LangChain's document loading patterns. +-} +module Langchain.DocumentLoader.FileLoader + ( FileLoader (..) + ) where + +import Control.Exception (SomeException, try) +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value (..)) +import Data.Map (fromList) +import qualified Data.Text as T +import qualified Data.Text.Lazy.IO as TLIO +import System.Directory (doesFileExist) + +import Langchain.DocumentLoader.Core (BaseLoader (..), Document (..)) +import Langchain.Error (documentLoaderError) + +-- | File loader configuration +newtype FileLoader = FileLoader FilePath + deriving (Eq, Show) + +instance BaseLoader FileLoader where + load (FileLoader path) = do + exists <- liftIO $ doesFileExist path + if exists + then do + eContent <- liftIO $ try (TLIO.readFile path) + case eContent of + Left err -> + throwError $ + documentLoaderError + (T.pack $ "Error reading file " ++ path ++ ": " ++ show (err :: SomeException)) + (Just "FileLoader") + (Just $ T.pack path) + Right content -> do + let meta = fromList [("source", String $ T.pack path)] + pure [Document content meta] + else + throwError $ + documentLoaderError + (T.pack $ "File not found: " ++ path) + (Just "FileLoader") + (Just $ T.pack path) diff --git a/src/Langchain/Embeddings.hs b/src/Langchain/Embeddings.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Embeddings.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE FlexibleContexts #-} + +{- | +Module : Langchain.Embeddings +Description : Effect-polymorphic embedding model interface +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Effect-polymorphic Embeddings typeclass. +-} +module Langchain.Embeddings + ( Embeddings (..) + ) where + +import Control.Monad.Except (MonadError) +import Control.Monad.IO.Class (MonadIO) +import Data.Text (Text) + +import Langchain.DocumentLoader.Core (Document) +import Langchain.Error (LangchainError) + +-- | Effect-polymorphic Embeddings typeclass +class Embeddings embed where + -- | Convert documents to embedding vectors + embedDocuments :: + (MonadIO m, MonadError LangchainError m) => + embed -> + [Document] -> + m [[Float]] + + -- | Convert query text to embedding vector + embedQuery :: + (MonadIO m, MonadError LangchainError m) => + embed -> + Text -> + m [Float] diff --git a/src/Langchain/Embeddings/Core.hs b/src/Langchain/Embeddings/Core.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Embeddings/Core.hs @@ -0,0 +1,13 @@ +{- | +Module : Langchain.Embeddings.Core +Description : Re-export of Langchain.Embeddings for backward compatibility +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +-} +module Langchain.Embeddings.Core + ( module Langchain.Embeddings + ) where + +import Langchain.Embeddings diff --git a/src/Langchain/Error.hs b/src/Langchain/Error.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Error.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Langchain.Error +Description : Core structured error types and context metadata +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Structured error handling without String-based error dropping. +-} +module Langchain.Error + ( LangchainError (..) + , ErrorContext (..) + , LangchainResult + , errorMessage + , mkContext + , mkContextIO + , llmError + , agentError + , memoryError + , toolError + , vectorStoreError + , documentLoaderError + , embeddingError + , runnableError + , parsingError + , networkError + , configurationError + , validationError + , internalError + ) where + +import Control.Exception (Exception (..)) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (FromJSON, ToJSON) +import Data.Map (Map) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (UTCTime, getCurrentTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import GHC.Generics (Generic) + +-- | Detailed context metadata attached to every error. +data ErrorContext = ErrorContext + { component :: Text + , operation :: Text + , timestamp :: UTCTime + , details :: Map Text Text + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | Pure context constructor. +mkContext :: Text -> Text -> Map Text Text -> ErrorContext +mkContext comp op = ErrorContext comp op (posixSecondsToUTCTime 0) + +-- | IO context constructor with real timestamp. +mkContextIO :: MonadIO m => Text -> Text -> Map Text Text -> m ErrorContext +mkContextIO comp op dt = do + now <- liftIO getCurrentTime + pure $ ErrorContext comp op now dt + +-- | Core framework error type. +data LangchainError + = LLMError Text (Maybe ErrorContext) + | AgentError Text (Maybe ErrorContext) + | MemoryError Text (Maybe ErrorContext) + | ToolError Text (Maybe ErrorContext) + | VectorStoreError Text (Maybe ErrorContext) + | DocumentLoaderError Text (Maybe ErrorContext) + | EmbeddingError Text (Maybe ErrorContext) + | RunnableError Text (Maybe ErrorContext) + | ParsingError Text (Maybe ErrorContext) + | NetworkError Text (Maybe ErrorContext) + | ConfigurationError Text (Maybe ErrorContext) + | ValidationError Text (Maybe ErrorContext) + | InternalError Text (Maybe ErrorContext) + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | Type alias for Either LangchainError a +type LangchainResult a = Either LangchainError a + +-- | Extract human-readable error message text from a LangchainError +errorMessage :: LangchainError -> Text +errorMessage (LLMError msg _) = msg +errorMessage (AgentError msg _) = msg +errorMessage (MemoryError msg _) = msg +errorMessage (ToolError msg _) = msg +errorMessage (VectorStoreError msg _) = msg +errorMessage (DocumentLoaderError msg _) = msg +errorMessage (EmbeddingError msg _) = msg +errorMessage (RunnableError msg _) = msg +errorMessage (ParsingError msg _) = msg +errorMessage (NetworkError msg _) = msg +errorMessage (ConfigurationError msg _) = msg +errorMessage (ValidationError msg _) = msg +errorMessage (InternalError msg _) = msg + +instance Exception LangchainError where + displayException err = case err of + LLMError msg ctx -> formatError "LLMError" msg ctx + AgentError msg ctx -> formatError "AgentError" msg ctx + MemoryError msg ctx -> formatError "MemoryError" msg ctx + ToolError msg ctx -> formatError "ToolError" msg ctx + VectorStoreError msg ctx -> formatError "VectorStoreError" msg ctx + DocumentLoaderError msg ctx -> formatError "DocumentLoaderError" msg ctx + EmbeddingError msg ctx -> formatError "EmbeddingError" msg ctx + RunnableError msg ctx -> formatError "RunnableError" msg ctx + ParsingError msg ctx -> formatError "ParsingError" msg ctx + NetworkError msg ctx -> formatError "NetworkError" msg ctx + ConfigurationError msg ctx -> formatError "ConfigurationError" msg ctx + ValidationError msg ctx -> formatError "ValidationError" msg ctx + InternalError msg ctx -> formatError "InternalError" msg ctx + where + formatError errType msg Nothing = errType ++ ": " ++ T.unpack msg + formatError errType msg (Just ctx) = + errType + ++ ": " + ++ T.unpack msg + ++ " [Component: " + ++ T.unpack (component ctx) + ++ ", Operation: " + ++ T.unpack (operation ctx) + ++ "]" + +-- | Helper constructors +mkErrorCtx :: + (Text -> Maybe ErrorContext -> LangchainError) -> Text -> Maybe Text -> Maybe Text -> LangchainError +mkErrorCtx ctor msg mbComp mbOp = + let mbCtx = case (mbComp, mbOp) of + (Nothing, Nothing) -> Nothing + (Just c, Just o) -> Just $ mkContext c o mempty + (Just c, Nothing) -> Just $ mkContext c "unspecified" mempty + (Nothing, Just o) -> Just $ mkContext "unspecified" o mempty + in ctor msg mbCtx + +-- | Construct an 'LLMError' with optional component and operation. +llmError :: Text -> Maybe Text -> Maybe Text -> LangchainError +llmError = mkErrorCtx LLMError + +-- | Construct an 'AgentError' with optional component and operation. +agentError :: Text -> Maybe Text -> Maybe Text -> LangchainError +agentError = mkErrorCtx AgentError + +-- | Construct a 'MemoryError' with optional component and operation. +memoryError :: Text -> Maybe Text -> Maybe Text -> LangchainError +memoryError = mkErrorCtx MemoryError + +-- | Construct a 'ToolError' with optional component and operation. +toolError :: Text -> Maybe Text -> Maybe Text -> LangchainError +toolError = mkErrorCtx ToolError + +-- | Construct a 'VectorStoreError' with optional component and operation. +vectorStoreError :: Text -> Maybe Text -> Maybe Text -> LangchainError +vectorStoreError = mkErrorCtx VectorStoreError + +-- | Construct a 'DocumentLoaderError' with optional component and operation. +documentLoaderError :: Text -> Maybe Text -> Maybe Text -> LangchainError +documentLoaderError = mkErrorCtx DocumentLoaderError + +-- | Construct an 'EmbeddingError' with optional component and operation. +embeddingError :: Text -> Maybe Text -> Maybe Text -> LangchainError +embeddingError = mkErrorCtx EmbeddingError + +-- | Construct a 'RunnableError' with optional component and operation. +runnableError :: Text -> Maybe Text -> Maybe Text -> LangchainError +runnableError = mkErrorCtx RunnableError + +-- | Construct a 'ParsingError' with optional component and operation. +parsingError :: Text -> Maybe Text -> Maybe Text -> LangchainError +parsingError = mkErrorCtx ParsingError + +-- | Construct a 'NetworkError' with optional component and operation. +networkError :: Text -> Maybe Text -> Maybe Text -> LangchainError +networkError = mkErrorCtx NetworkError + +-- | Construct a 'ConfigurationError' with optional component and operation. +configurationError :: Text -> Maybe Text -> Maybe Text -> LangchainError +configurationError = mkErrorCtx ConfigurationError + +-- | Construct a 'ValidationError' with optional component and operation. +validationError :: Text -> Maybe Text -> Maybe Text -> LangchainError +validationError = mkErrorCtx ValidationError + +-- | Construct an 'InternalError' with optional component and operation. +internalError :: Text -> Maybe Text -> Maybe Text -> LangchainError +internalError = mkErrorCtx InternalError diff --git a/src/Langchain/Guardrail.hs b/src/Langchain/Guardrail.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Guardrail.hs @@ -0,0 +1,16 @@ +{- | +Module : Langchain.Guardrail +Description : Input/output validation guardrails and safety filters +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Composable guardrails for validating prompt safety, topic restriction, +and response format constraints. +-} +module Langchain.Guardrail + ( module Langchain.Guardrail.Core + ) where + +import Langchain.Guardrail.Core diff --git a/src/Langchain/Guardrail/Core.hs b/src/Langchain/Guardrail/Core.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Guardrail/Core.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Langchain.Guardrail.Core +Description : Agent input/output validation guardrails and safety filters +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Composable guardrails for validating prompt safety, topic restriction, and response format constraints. +-} +module Langchain.Guardrail.Core + ( GuardrailResult (..) + , Guardrail (..) + , contentSafetyGuardrail + , topicGuardrail + , outputLengthGuardrail + , composeGuardrails + , withGuardrails + ) where + +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.IO.Class (MonadIO) +import Data.Text (Text) +import qualified Data.Text as T + +import Langchain.Error (LangchainError, agentError) +import Langchain.Model + ( ChatModel (..) + , extractMessageText + , userMessage + ) + +-- | Outcome of evaluating a guardrail check +data GuardrailResult + = GuardrailPass + | GuardrailFail !Text -- Reason for failure + deriving (Show, Eq) + +-- | Composable guardrail container +data Guardrail m = Guardrail + { guardrailName :: !Text + , validateInput :: Text -> m GuardrailResult + , validateOutput :: Text -> m GuardrailResult + } + +-- | Simple keyword-based content safety guardrail +contentSafetyGuardrail :: MonadIO m => [Text] -> Guardrail m +contentSafetyGuardrail forbiddenWords = + Guardrail + { guardrailName = "ContentSafety" + , validateInput = \input -> + let lower = T.toLower input + matched = filter (`T.isInfixOf` lower) (map T.toLower forbiddenWords) + in pure $ + if null matched + then GuardrailPass + else GuardrailFail ("Input contains forbidden content: " <> T.intercalate ", " matched) + , validateOutput = \output -> + let lower = T.toLower output + matched = filter (`T.isInfixOf` lower) (map T.toLower forbiddenWords) + in pure $ + if null matched + then GuardrailPass + else GuardrailFail ("Output contains forbidden content: " <> T.intercalate ", " matched) + } + +-- | Output length guardrail +outputLengthGuardrail :: MonadIO m => Int -> Guardrail m +outputLengthGuardrail maxLen = + Guardrail + { guardrailName = "OutputLength" + , validateInput = \_ -> pure GuardrailPass + , validateOutput = \out -> + if T.length out <= maxLen + then pure GuardrailPass + else + pure $ + GuardrailFail + ("Output length (" <> T.pack (show (T.length out)) <> ") exceeds limit of " <> T.pack (show maxLen)) + } + +-- | LLM-based topic relevance guardrail +topicGuardrail :: + (ChatModel model, MonadIO m, MonadError LangchainError m) => model -> Text -> Guardrail m +topicGuardrail model allowedTopic = + Guardrail + { guardrailName = "TopicRestriction" + , validateInput = \input -> do + let prompt = + "Allowed Topic: " + <> allowedTopic + <> "\n\nUser Input: " + <> input + <> "\nIs the user input relevant to the allowed topic? Reply ONLY with 'YES' or 'NO: '." + resp <- invoke model [userMessage prompt] Nothing + let ans = T.strip (extractMessageText resp) + pure $ + if "YES" `T.isPrefixOf` ans + then GuardrailPass + else GuardrailFail ("Topic violation: " <> ans) + , validateOutput = \_ -> pure GuardrailPass + } + +-- | Compose multiple guardrails in sequence +composeGuardrails :: (MonadIO m) => [Guardrail m] -> Guardrail m +composeGuardrails [] = + Guardrail "NoOp" (\_ -> pure GuardrailPass) (\_ -> pure GuardrailPass) +composeGuardrails rails = + Guardrail + { guardrailName = T.intercalate "+" (map guardrailName rails) + , validateInput = checkAll (map validateInput rails) + , validateOutput = checkAll (map validateOutput rails) + } + where + checkAll [] _ = pure GuardrailPass + checkAll (v : vs) txt = do + res <- v txt + case res of + GuardrailPass -> checkAll vs txt + failRes -> pure failRes + +-- | Execute an action wrapped by input and output guardrails +withGuardrails :: + (MonadIO m, MonadError LangchainError m) => + Guardrail m -> + (Text -> m Text) -> + Text -> + m Text +withGuardrails rail action input = do + inRes <- validateInput rail input + case inRes of + GuardrailFail reason -> + throwError $ agentError ("Input guardrail failed: " <> reason) (Just (guardrailName rail)) Nothing + GuardrailPass -> do + output <- action input + outRes <- validateOutput rail output + case outRes of + GuardrailFail reason -> + throwError $ agentError ("Output guardrail failed: " <> reason) (Just (guardrailName rail)) Nothing + GuardrailPass -> pure output diff --git a/src/Langchain/Memory.hs b/src/Langchain/Memory.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Memory.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +{- | +Module : Langchain.Memory +Description : Conversation memory interfaces and implementations +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Conversation memory management including: +* Unbounded buffer memory ('ConversationBufferMemory') +* Sliding window memory ('WindowBufferMemory') +* Token-budgeted sliding buffer ('TokenBufferMemory') +* Progressive transactional summarization memory ('SummaryMemory') +* Multi-session memory stores with TTL eviction ('SessionMemoryStore') +* Structured entity and attribute fact memory ('EntityMemory') +* Composite memory combinations ('CombinedMemory') +* JSON file persistence and variable loading +-} +module Langchain.Memory + ( module Langchain.Memory.Core + , module Langchain.Memory.Summary + , module Langchain.Memory.Session + , module Langchain.Memory.Entity + , module Langchain.Memory.Combined + ) where + +import Langchain.Memory.Combined +import Langchain.Memory.Core +import Langchain.Memory.Entity +import Langchain.Memory.Session +import Langchain.Memory.Summary diff --git a/src/Langchain/Memory/Combined.hs b/src/Langchain/Memory/Combined.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Memory/Combined.hs @@ -0,0 +1,49 @@ +{- | +Module : Langchain.Memory.Combined +Description : Composition of multiple heterogeneous memory stores +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Composite memory combining multiple distinct memory backends (e.g. WindowBufferMemory + EntityMemory) +into a single unified BaseMemory interface. Broadcasts inputs to all child memories and aggregates +their history and variable outputs. +-} +module Langchain.Memory.Combined + ( CombinedMemory (..) + , newCombinedMemory + ) where + +import Control.Monad (forM_) + +import Langchain.Memory.Core (BaseMemory (..), SomeMemory (..)) + +-- | Composite memory multiplexing over a list of existential 'SomeMemory' instances +newtype CombinedMemory = CombinedMemory + { memories :: [SomeMemory] + } + +-- | Construct a new CombinedMemory from a list of 'SomeMemory' wrappers +newCombinedMemory :: [SomeMemory] -> CombinedMemory +newCombinedMemory = CombinedMemory + +instance BaseMemory CombinedMemory where + messages (CombinedMemory mems) = do + listOfLists <- mapM messages mems + pure $ concat listOfLists + + addMessage (CombinedMemory mems) msg = + forM_ mems (`addMessage` msg) + + addUserMessage (CombinedMemory mems) txt = + forM_ mems (`addUserMessage` txt) + + addAiMessage (CombinedMemory mems) txt = + forM_ mems (`addAiMessage` txt) + + clear (CombinedMemory mems) = + forM_ mems clear + + importMessages (CombinedMemory mems) msgs = + forM_ mems (`importMessages` msgs) diff --git a/src/Langchain/Memory/Core.hs b/src/Langchain/Memory/Core.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Memory/Core.hs @@ -0,0 +1,455 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Langchain.Memory.Core +Description : Effect-polymorphic, thread-safe conversation memory interfaces +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Thread-safe, effect-polymorphic conversation memory interfaces using STM. +Includes sliding window buffers, token-budgeted buffers, unbounded conversation buffers, +context saving, variable loading for prompt interpolation, and JSON persistence. +-} +module Langchain.Memory.Core + ( -- * Base Memory Interface + BaseMemory (..) + , SomeMemory (..) + + -- * Context Saving & Variable Loading + , saveContext + , loadMemoryVariables + , formatHistory + , formatHistoryWithLabels + + -- * Memory Implementations + , ConversationBufferMemory (..) + , newConversationBufferMemory + , WindowBufferMemory (..) + , newWindowBufferMemory + , TokenBufferMemory (..) + , newTokenBufferMemory + , newTokenBufferMemoryWithStrategy + , OverflowStrategy (..) + , TokenCounter + + -- * Persistence & Serialization + , exportMessages + , saveMemoryToFile + , loadMemoryFromFile + + -- * Utility Functions + , countTokens + , approximateTokenCount + , trimMessages + , initialMessages + , resetToInitial + , resetConversationBuffer + , resetWindowBuffer + , resetTokenBuffer + ) where + +import Control.Concurrent.STM + ( TVar + , atomically + , modifyTVar' + , newTVarIO + , readTVarIO + , writeTVar + ) +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (decode, encode) +import qualified Data.ByteString.Lazy as BSL +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) + +import Langchain.Error (LangchainError, memoryError) +import Langchain.Model + ( Message (..) + , Role (..) + , assistantMessage + , extractMessageText + , systemMessage + , userMessage + ) + +-- --------------------------------------------------------------------------- +-- Base Memory Interface +-- --------------------------------------------------------------------------- + +-- | Effect-polymorphic BaseMemory typeclass providing full conversation management. +class BaseMemory mem where + -- | Retrieve current conversation messages + messages :: + (MonadIO m, MonadError LangchainError m) => + mem -> + m [Message] + + -- | Add a structured message to history + addMessage :: + (MonadIO m, MonadError LangchainError m) => + mem -> + Message -> + m () + + -- | Add a user message to history + addUserMessage :: + (MonadIO m, MonadError LangchainError m) => + mem -> + Text -> + m () + addUserMessage mem txt = addMessage mem (userMessage txt) + + -- | Add an AI response message to history + addAiMessage :: + (MonadIO m, MonadError LangchainError m) => + mem -> + Text -> + m () + addAiMessage mem txt = addMessage mem (assistantMessage txt) + + -- | Reset memory to initial state + clear :: + (MonadIO m, MonadError LangchainError m) => + mem -> + m () + + -- | Import and replace conversation messages completely + importMessages :: + (MonadIO m, MonadError LangchainError m) => + mem -> + [Message] -> + m () + importMessages mem msgs = do + clear mem + mapM_ (addMessage mem) msgs + +-- | Atomically record both user input and AI response in a single step +saveContext :: + (BaseMemory mem, MonadIO m, MonadError LangchainError m) => + mem -> + Text -> + Text -> + m () +saveContext mem userTxt aiTxt = do + addUserMessage mem userTxt + addAiMessage mem aiTxt + +-- | Load memory variables as a Map for direct prompt template interpolation +loadMemoryVariables :: + (BaseMemory mem, MonadIO m, MonadError LangchainError m) => + mem -> + m (Map Text Text) +loadMemoryVariables mem = do + msgs <- messages mem + pure $ Map.singleton "history" (formatHistory msgs) + +-- | Format conversation messages to standard string representation +formatHistory :: [Message] -> Text +formatHistory = formatHistoryWithLabels "Human" "AI" + +-- | Format conversation messages with custom role labels +formatHistoryWithLabels :: Text -> Text -> [Message] -> Text +formatHistoryWithLabels userLabel aiLabel msgs = + T.intercalate "\n" (map formatMsg msgs) + where + formatMsg m = + let prefix = case messageRole m of + User -> userLabel <> ": " + Assistant -> aiLabel <> ": " + System -> "System: " + Tool -> "Tool: " + Function -> "Function: " + Developer -> "Developer: " + in prefix <> extractMessageText m + +-- --------------------------------------------------------------------------- +-- Existential Wrapper +-- --------------------------------------------------------------------------- + +-- | Existential wrapper for any 'BaseMemory' instance +data SomeMemory where + SomeMemory :: (BaseMemory mem) => mem -> SomeMemory + +instance BaseMemory SomeMemory where + messages (SomeMemory m) = messages m + addMessage (SomeMemory m) = addMessage m + clear (SomeMemory m) = clear m + addUserMessage (SomeMemory m) = addUserMessage m + addAiMessage (SomeMemory m) = addAiMessage m + importMessages (SomeMemory m) = importMessages m + +-- | No-op BaseMemory instance for unit +instance BaseMemory () where + messages () = pure [] + addMessage () _ = pure () + clear () = pure () + +-- --------------------------------------------------------------------------- +-- ConversationBufferMemory (Unbounded) +-- --------------------------------------------------------------------------- + +-- | Unbounded conversation memory keeping the full message history in a thread-safe STM TVar +data ConversationBufferMemory = ConversationBufferMemory + { memVar :: !(TVar [Message]) + , initialMessagesList :: ![Message] + } + +instance Show ConversationBufferMemory where + show _ = "ConversationBufferMemory" + +instance Eq ConversationBufferMemory where + (ConversationBufferMemory tv1 _) == (ConversationBufferMemory tv2 _) = tv1 == tv2 + +-- | Construct a new unbounded ConversationBufferMemory +newConversationBufferMemory :: (MonadIO m) => [Message] -> m ConversationBufferMemory +newConversationBufferMemory initMsgs = liftIO $ do + tv <- newTVarIO initMsgs + pure $ ConversationBufferMemory tv initMsgs + +instance BaseMemory ConversationBufferMemory where + messages (ConversationBufferMemory tv _) = liftIO $ readTVarIO tv + + addMessage (ConversationBufferMemory tv _) newMsg = liftIO $ atomically $ do + modifyTVar' tv (\curr -> curr ++ [newMsg]) + + clear (ConversationBufferMemory tv inits) = liftIO $ atomically $ do + let resetMsgs = if null inits then [systemMessage "You are a helpful AI assistant"] else inits + writeTVar tv resetMsgs + + importMessages (ConversationBufferMemory tv _) msgs = liftIO $ atomically $ do + writeTVar tv msgs + +-- --------------------------------------------------------------------------- +-- WindowBufferMemory (Sliding Window by Count) +-- --------------------------------------------------------------------------- + +-- | Sliding window memory backed by thread-safe STM TVar +data WindowBufferMemory = WindowBufferMemory + { maxWindowSize :: !Int + , memVar :: !(TVar [Message]) + , initialMessagesList :: ![Message] + } + +instance Show WindowBufferMemory where + show (WindowBufferMemory sz _ _) = "WindowBufferMemory { maxWindowSize = " ++ show sz ++ " }" + +instance Eq WindowBufferMemory where + (WindowBufferMemory sz1 tv1 _) == (WindowBufferMemory sz2 tv2 _) = + sz1 == sz2 && tv1 == tv2 + +-- | Construct a thread-safe WindowBufferMemory in MonadIO +newWindowBufferMemory :: + (MonadIO m) => + -- | Maximum message window size + Int -> + -- | Initial messages to seed the window + [Message] -> + -- | Initialized thread-safe WindowBufferMemory + m WindowBufferMemory +newWindowBufferMemory sz initMsgs = liftIO $ do + tv <- newTVarIO initMsgs + pure $ WindowBufferMemory sz tv initMsgs + +instance BaseMemory WindowBufferMemory where + messages (WindowBufferMemory _ tv _) = liftIO $ readTVarIO tv + + addMessage (WindowBufferMemory maxSz tv _) newMsg = liftIO $ do + atomically $ modifyTVar' tv $ \currMsgs -> + let combined = currMsgs ++ [newMsg] + in if length combined > maxSz + then removeOldestNonSystem combined + else combined + where + removeOldestNonSystem [] = [] + removeOldestNonSystem (m : ms) + | messageRole m == System = m : removeOldestNonSystem ms + | otherwise = ms + + clear (WindowBufferMemory _ tv _) = liftIO $ do + atomically $ writeTVar tv [systemMessage "You are a helpful AI assistant"] + + importMessages (WindowBufferMemory _ tv _) msgs = liftIO $ atomically $ do + writeTVar tv msgs + +-- --------------------------------------------------------------------------- +-- TokenBufferMemory (Sliding Window by Token Budget) +-- --------------------------------------------------------------------------- + +-- | Strategy for handling incoming messages that exceed token capacity +data OverflowStrategy + = EvictOldest + | RejectOnOverflow + deriving (Show, Eq, Generic) + +-- | Function type for counting tokens in a list of messages +type TokenCounter = [Message] -> Int + +-- | Approximate token count: 4 characters ≈ 1 token +approximateTokenCount :: [Message] -> Int +approximateTokenCount = + sum . map (\m -> ceiling (fromIntegral (T.length (extractMessageText m)) / (4.0 :: Double))) + +-- | Approximate token count alias for backwards compatibility +countTokens :: [Message] -> Int +countTokens = approximateTokenCount + +-- | Token-based sliding window memory type +data TokenBufferMemory = TokenBufferMemory + { maxTokens :: !Int + , memVar :: !(TVar [Message]) + , overflowStrategy :: !OverflowStrategy + , tokenCounter :: !TokenCounter + , initialMessagesList :: ![Message] + } + +instance Show TokenBufferMemory where + show (TokenBufferMemory maxT _ strat _ _) = + "TokenBufferMemory { maxTokens = " ++ show maxT ++ ", overflowStrategy = " ++ show strat ++ " }" + +instance Eq TokenBufferMemory where + (TokenBufferMemory t1 tv1 s1 _ _) == (TokenBufferMemory t2 tv2 s2 _ _) = + t1 == t2 && tv1 == tv2 && s1 == s2 + +-- | Construct a new TokenBufferMemory with default eviction strategy and approximate counting +newTokenBufferMemory :: + (MonadIO m) => + -- | Maximum allowed tokens in history + Int -> + -- | Initial messages to seed the buffer + [Message] -> + -- | Initialized thread-safe TokenBufferMemory + m TokenBufferMemory +newTokenBufferMemory maxT initMsgs = + newTokenBufferMemoryWithStrategy maxT initMsgs EvictOldest approximateTokenCount + +-- | Construct a TokenBufferMemory with explicit overflow strategy and custom token counter +newTokenBufferMemoryWithStrategy :: + (MonadIO m) => + Int -> + [Message] -> + OverflowStrategy -> + TokenCounter -> + m TokenBufferMemory +newTokenBufferMemoryWithStrategy maxT initMsgs strat counter = liftIO $ do + tv <- newTVarIO initMsgs + pure $ TokenBufferMemory maxT tv strat counter initMsgs + +instance BaseMemory TokenBufferMemory where + messages (TokenBufferMemory _ tv _ _ _) = liftIO $ readTVarIO tv + + addMessage (TokenBufferMemory maxT tv _ counter _) newMsg = do + let newMsgTokens = counter [newMsg] + if newMsgTokens > maxT + then + throwError $ + memoryError "New message exceeds maximum token limit" (Just "TokenBufferMemory") Nothing + else liftIO $ atomically $ modifyTVar' tv $ \currMsgs -> + trimToLimit currMsgs newMsgTokens [newMsg] + where + trimToLimit currMsgs newMsgToks acc = + let candidate = currMsgs ++ acc + in if counter candidate <= maxT + then candidate + else case removeOldestNonSystem currMsgs of + Just trimmed -> trimToLimit trimmed newMsgToks acc + Nothing -> [newMsg] + + removeOldestNonSystem [] = Nothing + removeOldestNonSystem (m : ms) + | messageRole m == System = fmap (m :) (removeOldestNonSystem ms) + | otherwise = Just ms + + clear (TokenBufferMemory _ tv _ _ _) = liftIO $ do + atomically $ writeTVar tv [systemMessage "You are a helpful AI assistant"] + + importMessages (TokenBufferMemory _ tv _ _ _) msgs = liftIO $ atomically $ do + writeTVar tv msgs + +-- --------------------------------------------------------------------------- +-- Persistence & Serialization +-- --------------------------------------------------------------------------- + +-- | Export all conversation messages from memory +exportMessages :: + (BaseMemory mem, MonadIO m, MonadError LangchainError m) => + mem -> + m [Message] +exportMessages = messages + +-- | Persist memory state to a JSON file +saveMemoryToFile :: + (BaseMemory mem, MonadIO m, MonadError LangchainError m) => + FilePath -> + mem -> + m () +saveMemoryToFile path mem = do + msgs <- messages mem + liftIO $ BSL.writeFile path (encode msgs) + +-- | Load memory state from a JSON file +loadMemoryFromFile :: + (BaseMemory mem, MonadIO m, MonadError LangchainError m) => + FilePath -> + mem -> + m () +loadMemoryFromFile path mem = do + content <- liftIO $ BSL.readFile path + case decode content of + Nothing -> + throwError $ + memoryError + ("Failed to parse memory JSON from file: " <> T.pack path) + (Just "loadMemoryFromFile") + Nothing + Just msgs -> importMessages mem msgs + +-- --------------------------------------------------------------------------- +-- Utilities +-- --------------------------------------------------------------------------- + +-- | Reset memory back to its exact initial messages +resetToInitial :: + (MonadIO m) => + TVar [Message] -> + [Message] -> + m () +resetToInitial tv inits = liftIO $ atomically $ writeTVar tv inits + +-- | Reset a 'ConversationBufferMemory' back to its initial seed messages +resetConversationBuffer :: (MonadIO m) => ConversationBufferMemory -> m () +resetConversationBuffer (ConversationBufferMemory tv inits) = resetToInitial tv inits + +-- | Reset a 'WindowBufferMemory' back to its initial seed messages +resetWindowBuffer :: (MonadIO m) => WindowBufferMemory -> m () +resetWindowBuffer (WindowBufferMemory _ tv inits) = resetToInitial tv inits + +-- | Reset a 'TokenBufferMemory' back to its initial seed messages +resetTokenBuffer :: (MonadIO m) => TokenBufferMemory -> m () +resetTokenBuffer (TokenBufferMemory _ tv _ _ inits) = resetToInitial tv inits + +-- | Pure helper to trim messages to last N +trimMessages :: + -- | Number of most recent messages to keep + Int -> + -- | Input message list + [Message] -> + -- | Trimmed message list + [Message] +trimMessages n msgs = drop (max 0 (length msgs - n)) msgs + +-- | Pure helper to construct initial system message history +initialMessages :: + -- | System prompt text + Text -> + -- | Initial message history with system message + [Message] +initialMessages sysPrompt = [systemMessage sysPrompt] diff --git a/src/Langchain/Memory/Entity.hs b/src/Langchain/Memory/Entity.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Memory/Entity.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.Memory.Entity +Description : Structured key-value and entity fact memory +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Thread-safe entity and fact memory. +Retains user attributes, preferences, and extracted facts across conversation turns +for injection into prompt variables and system messages. +-} +module Langchain.Memory.Entity + ( EntityMemory (..) + , newEntityMemory + , setEntity + , getEntity + , getAllEntities + , deleteEntity + , clearEntities + , formatEntities + , resetEntitiesToInitial + ) where + +import Control.Concurrent.STM + ( TVar + , atomically + , modifyTVar' + , newTVarIO + , readTVarIO + , writeTVar + ) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T + +import Langchain.Memory.Core (BaseMemory (..)) +import Langchain.Model (systemMessage) + +-- | Entity memory holding key-value facts and attributes in STM +data EntityMemory = EntityMemory + { entityVar :: !(TVar (Map Text Text)) + , initialEntities :: !(Map Text Text) + } + +-- | Construct a new EntityMemory with optional initial facts +newEntityMemory :: MonadIO m => Map Text Text -> m EntityMemory +newEntityMemory inits = liftIO $ do + var <- newTVarIO inits + pure $ EntityMemory var inits + +-- | Set or update a specific entity attribute +setEntity :: MonadIO m => EntityMemory -> Text -> Text -> m () +setEntity EntityMemory {..} key val = liftIO $ atomically $ do + modifyTVar' entityVar (Map.insert key val) + +-- | Look up a specific entity attribute +getEntity :: MonadIO m => EntityMemory -> Text -> m (Maybe Text) +getEntity EntityMemory {..} key = liftIO $ do + m <- readTVarIO entityVar + pure $ Map.lookup key m + +-- | Retrieve all current entity facts +getAllEntities :: MonadIO m => EntityMemory -> m (Map Text Text) +getAllEntities EntityMemory {..} = liftIO $ readTVarIO entityVar + +-- | Delete an entity attribute +deleteEntity :: MonadIO m => EntityMemory -> Text -> m () +deleteEntity EntityMemory {..} key = liftIO $ atomically $ do + modifyTVar' entityVar (Map.delete key) + +-- | Clear all entity attributes +clearEntities :: MonadIO m => EntityMemory -> m () +clearEntities EntityMemory {..} = liftIO $ atomically $ do + writeTVar entityVar Map.empty + +-- | Reset entity memory back to its initial seed facts +resetEntitiesToInitial :: MonadIO m => EntityMemory -> m () +resetEntitiesToInitial EntityMemory {..} = liftIO $ atomically $ do + writeTVar entityVar initialEntities + +-- | Format key-value entities into bullet points +formatEntities :: Map Text Text -> Text +formatEntities m + | Map.null m = "" + | otherwise = + T.intercalate "\n" ["- " <> k <> ": " <> v | (k, v) <- Map.toList m] + +instance BaseMemory EntityMemory where + messages EntityMemory {..} = liftIO $ do + m <- readTVarIO entityVar + if Map.null m + then pure [] + else pure [systemMessage ("Relevant context facts:\n" <> formatEntities m)] + + addMessage _ _ = pure () + + clear = clearEntities diff --git a/src/Langchain/Memory/Session.hs b/src/Langchain/Memory/Session.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Memory/Session.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.Memory.Session +Description : Multi-session conversation memory management with TTL eviction +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Thread-safe multi-session conversation store. +Provides per-session memory isolation for web servers, chatbots, and multi-tenant agents +with configurable Time-To-Live (TTL) expiration to avoid unbounded memory leaks. +-} +module Langchain.Memory.Session + ( SessionId + , SessionMemoryStore (..) + , newSessionMemoryStore + , newSessionMemoryStoreWithTTL + , getSessionMemory + , listSessions + , hasSession + , deleteSession + , clearAllSessions + , sessionCount + , cleanupExpiredSessions + , exportAllSessions + ) where + +import Control.Concurrent.STM + ( TVar + , atomically + , modifyTVar' + , newTVarIO + , readTVar + , readTVarIO + , writeTVar + ) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime) + +import Langchain.Model (Message) + +-- | Unique identifier for a conversation session (e.g. user ID, session token, or UUID) +type SessionId = Text + +-- | Thread-safe multi-session memory repository +data SessionMemoryStore mem = SessionMemoryStore + { storeVar :: !(TVar (Map SessionId (mem, UTCTime))) + , memFactory :: !(SessionId -> IO mem) + , sessionTTL :: !(Maybe NominalDiffTime) + } + +-- | Create a new SessionMemoryStore with no TTL (sessions persist until explicitly deleted) +newSessionMemoryStore :: + MonadIO m => + -- | Factory creating a fresh memory instance for a given SessionId + (SessionId -> IO mem) -> + m (SessionMemoryStore mem) +newSessionMemoryStore factory = liftIO $ do + var <- newTVarIO Map.empty + pure $ SessionMemoryStore var factory Nothing + +-- | Create a new SessionMemoryStore with automatic Time-To-Live expiration +newSessionMemoryStoreWithTTL :: + MonadIO m => + -- | Maximum idle time before session is considered expired + NominalDiffTime -> + -- | Factory creating a fresh memory instance for a given SessionId + (SessionId -> IO mem) -> + m (SessionMemoryStore mem) +newSessionMemoryStoreWithTTL ttl factory = liftIO $ do + var <- newTVarIO Map.empty + pure $ SessionMemoryStore var factory (Just ttl) + +-- | Retrieve (or create) the memory instance for a specific session, updating its last access timestamp +getSessionMemory :: + MonadIO m => + SessionMemoryStore mem -> + SessionId -> + m mem +getSessionMemory SessionMemoryStore {..} sId = liftIO $ do + now <- getCurrentTime + mExisting <- atomically $ do + m <- readTVar storeVar + case Map.lookup sId m of + Just (mem, lastAccess) -> + case sessionTTL of + Just ttl | diffUTCTime now lastAccess > ttl -> pure Nothing + _ -> do + modifyTVar' storeVar (Map.insert sId (mem, now)) + pure (Just mem) + Nothing -> pure Nothing + + case mExisting of + Just mem -> pure mem + Nothing -> do + newMem <- memFactory sId + atomically $ modifyTVar' storeVar (Map.insert sId (newMem, now)) + pure newMem + +-- | List all active session IDs +listSessions :: MonadIO m => SessionMemoryStore mem -> m [SessionId] +listSessions SessionMemoryStore {..} = liftIO $ do + m <- readTVarIO storeVar + pure $ Map.keys m + +-- | Check if a session exists and is not expired +hasSession :: MonadIO m => SessionMemoryStore mem -> SessionId -> m Bool +hasSession SessionMemoryStore {..} sId = liftIO $ do + now <- getCurrentTime + m <- readTVarIO storeVar + pure $ case Map.lookup sId m of + Just (_, lastAccess) -> + case sessionTTL of + Just ttl -> diffUTCTime now lastAccess <= ttl + Nothing -> True + Nothing -> False + +-- | Delete a specific session from the store +deleteSession :: MonadIO m => SessionMemoryStore mem -> SessionId -> m () +deleteSession SessionMemoryStore {..} sId = liftIO $ atomically $ do + modifyTVar' storeVar (Map.delete sId) + +-- | Remove all sessions from the store +clearAllSessions :: MonadIO m => SessionMemoryStore mem -> m () +clearAllSessions SessionMemoryStore {..} = liftIO $ atomically $ do + writeTVar storeVar Map.empty + +-- | Count active sessions +sessionCount :: MonadIO m => SessionMemoryStore mem -> m Int +sessionCount SessionMemoryStore {..} = liftIO $ do + m <- readTVarIO storeVar + pure $ Map.size m + +-- | Purge all sessions that have exceeded the TTL limit. Returns the number of evicted sessions. +cleanupExpiredSessions :: MonadIO m => SessionMemoryStore mem -> m Int +cleanupExpiredSessions SessionMemoryStore {..} = liftIO $ case sessionTTL of + Nothing -> pure 0 + Just ttl -> do + now <- getCurrentTime + atomically $ do + m <- readTVar storeVar + let (active, expired) = Map.partition (\(_, lastAccess) -> diffUTCTime now lastAccess <= ttl) m + writeTVar storeVar active + pure (Map.size expired) + +-- | Export all sessions' message histories +exportAllSessions :: + MonadIO m => + (mem -> m [Message]) -> + SessionMemoryStore mem -> + m (Map SessionId [Message]) +exportAllSessions getMsgs SessionMemoryStore {..} = do + sMap <- liftIO $ readTVarIO storeVar + Map.traverseWithKey (\_ (mem, _) -> getMsgs mem) sMap diff --git a/src/Langchain/Memory/Summary.hs b/src/Langchain/Memory/Summary.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Memory/Summary.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.Memory.Summary +Description : Summary-based conversation memory with progressive LLM summarization +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Progressively summarizes older conversation history using a ChatModel when history exceeds a threshold. +Guarantees transaction safety: conversation history is only pruned after the LLM summarization +call successfully completes, preventing irreversible data loss on network or model failures. +-} +module Langchain.Memory.Summary + ( SummaryMemory (..) + , newSummaryMemory + , newSummaryMemoryWithPrompt + , getSummary + , defaultSummaryPrompt + , formatMessages + ) where + +import Control.Concurrent.STM + ( TVar + , atomically + , modifyTVar' + , newTVarIO + , readTVar + , readTVarIO + , writeTVar + ) +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.List (partition) +import Data.Text (Text) +import qualified Data.Text as T + +import Langchain.Memory.Core (BaseMemory (..), formatHistory) +import Langchain.Model + ( ChatModel (..) + , Message (..) + , Role (..) + , extractMessageText + , systemMessage + , userMessage + ) + +-- | Progressive summarization memory backed by thread-safe STM TVars +data SummaryMemory model = SummaryMemory + { summaryModel :: model + , maxMessageThreshold :: !Int + , summaryBufferVar :: !(TVar Text) + , recentMessagesVar :: !(TVar [Message]) + , promptBuilder :: !(Text -> [Message] -> Text) + , initialMessagesList :: ![Message] + } + +-- | Default summarization prompt generator +defaultSummaryPrompt :: Text -> [Message] -> Text +defaultSummaryPrompt currentSummary toSummarize = + "Current summary:\n" + <> currentSummary + <> "\n\nNew lines to summarize:\n" + <> formatMessages toSummarize + <> "\n\nPlease provide an updated, concise summary of the conversation above." + +-- | Construct a new SummaryMemory instance with default prompt +newSummaryMemory :: MonadIO m => model -> Int -> [Message] -> m (SummaryMemory model) +newSummaryMemory model threshold initMsgs = + newSummaryMemoryWithPrompt model threshold initMsgs defaultSummaryPrompt + +-- | Construct a SummaryMemory instance with custom summarization prompt generator +newSummaryMemoryWithPrompt :: + MonadIO m => + model -> + Int -> + [Message] -> + (Text -> [Message] -> Text) -> + m (SummaryMemory model) +newSummaryMemoryWithPrompt model threshold initMsgs pBuilder = liftIO $ do + sVar <- newTVarIO "" + mVar <- newTVarIO initMsgs + pure $ SummaryMemory model threshold sVar mVar pBuilder initMsgs + +-- | Retrieve the current accumulated summary text +getSummary :: MonadIO m => SummaryMemory model -> m Text +getSummary SummaryMemory {..} = liftIO $ readTVarIO summaryBufferVar + +instance (ChatModel model) => BaseMemory (SummaryMemory model) where + messages SummaryMemory {..} = liftIO $ do + sumTxt <- readTVarIO summaryBufferVar + recent <- readTVarIO recentMessagesVar + if T.null sumTxt + then pure recent + else do + -- Preserve any system instructions at the head, followed by the summary, followed by recent turns + let (sysMsgs, nonSysMsgs) = partition (\m -> messageRole m == System) recent + summaryMsg = systemMessage ("Summary of previous conversation:\n" <> sumTxt) + pure (sysMsgs ++ [summaryMsg] ++ nonSysMsgs) + + addMessage SummaryMemory {..} newMsg = do + -- 1. Append message to recent buffer + (shouldSummarize, toSummarize, keepCount) <- liftIO $ atomically $ do + modifyTVar' recentMessagesVar (\msgs -> msgs ++ [newMsg]) + currentMsgs <- readTVar recentMessagesVar + if length currentMsgs > maxMessageThreshold + then do + let keep = max 2 (maxMessageThreshold `div` 2) + (old, _) = splitAt (length currentMsgs - keep) currentMsgs + pure (True, old, keep) + else pure (False, [], length currentMsgs) + + -- 2. If summarization threshold reached, execute LLM summarization. + -- Crucial: Pruning ONLY happens after the LLM invoke succeeds! + when (shouldSummarize && not (null toSummarize)) $ do + currentSummary <- liftIO $ readTVarIO summaryBufferVar + let summaryPrompt = promptBuilder currentSummary toSummarize + aiResp <- invoke summaryModel [userMessage summaryPrompt] Nothing + let newSummary = extractMessageText aiResp + + -- Atomically commit new summary and prune summarized messages + liftIO $ atomically $ do + writeTVar summaryBufferVar newSummary + modifyTVar' recentMessagesVar (\msgs -> drop (max 0 (length msgs - keepCount)) msgs) + + clear SummaryMemory {..} = liftIO $ atomically $ do + writeTVar summaryBufferVar "" + writeTVar recentMessagesVar [] + +formatMessages :: [Message] -> Text +formatMessages = formatHistory diff --git a/src/Langchain/Model.hs b/src/Langchain/Model.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Model.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module : Langchain.Model +Description : Central ChatModel typeclass for LLM providers +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Provides effect-polymorphic 'ChatModel' interface. +-} +module Langchain.Model + ( ChatModel (..) + , module Langchain.Model.Types + ) where + +import Control.Monad.Except (MonadError) +import Control.Monad.IO.Class (MonadIO) +import Data.Kind (Type) + +import Langchain.Error (LangchainError) +import Langchain.Model.Types +import Langchain.Stream (ChatStream) + +-- | Effect-polymorphic ChatModel typeclass for LLM providers +class ChatModel model where + type ModelConfig model :: Type + + -- | Single synchronous invocation + invoke :: + (MonadIO m, MonadError LangchainError m) => + model -> + [Message] -> + Maybe (ModelConfig model) -> + m Message + + -- | Batch invocations (default: sequential) + batch :: + (MonadIO m, MonadError LangchainError m) => + model -> + [[Message]] -> + Maybe (ModelConfig model) -> + m [Message] + batch model msgs cfg = mapM (\m -> invoke model m cfg) msgs + + -- | Streaming invocation yielding structured StreamEvents via Conduit + stream :: + model -> + [Message] -> + Maybe (ModelConfig model) -> + ChatStream diff --git a/src/Langchain/Model/Types.hs b/src/Langchain/Model/Types.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Model/Types.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-partial-fields #-} + +{- | +Module : Langchain.Model.Types +Description : Multi-modal ContentBlock and Message data types +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Data types for multi-modal messages, content blocks, roles, and tool calls. +-} +module Langchain.Model.Types + ( ContentBlock (..) + , ImageContent (..) + , ImageSource (..) + , Role (..) + , ToolCall (..) + , Message (..) + , textMessage + , userMessage + , systemMessage + , assistantMessage + , toolMessage + , imageMessage + , extractMessageText + , roleLabel + , formatMessageString + ) where + +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, withObject, (.:), (.:?), (.=)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64 as Base64 +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import GHC.Generics (Generic) + +-- | A single content block within a multi-modal message. +data ContentBlock + = TextBlock {blockText :: Text} + | ImageBlock ImageContent + | AudioBlock {blockMimeType :: Text, blockBase64 :: Text} + | DataBlock {blockBytes :: ByteString} + deriving (Eq, Show, Generic) + +-- | Multi-modal image content with source, optional detail, and metadata. +data ImageContent = ImageContent + { imageSource :: ImageSource + , imageDetail :: Maybe Text + , imageMetadata :: Maybe Value + } + deriving (Eq, Show, Generic) + +-- | Underlying image data source: either raw base64 or a remote URL. +data ImageSource + = ImageBase64 {imageMimeType :: Maybe Text, imageData :: Text} + | ImageUrl {imageUrl :: Text} + deriving (Eq, Show, Generic) + +instance ToJSON ContentBlock where + toJSON (TextBlock t) = object ["type" .= ("text" :: Text), "text" .= t] + toJSON (ImageBlock ImageContent {imageSource = ImageUrl url, imageDetail = detail}) = + object + [ "type" .= ("image_url" :: Text) + , "image_url" .= object (maybe id ((:) . ("detail" .=)) detail ["url" .= url]) + ] + toJSON (ImageBlock ImageContent {imageSource = ImageBase64 (Just mime) imageData, imageMetadata = metadata}) = + object $ + ["type" .= ("image" :: Text), "mime_type" .= mime, "data" .= imageData] + <> maybe [] (pure . ("metadata" .=)) metadata + toJSON (ImageBlock ImageContent {imageSource = ImageBase64 _ imageData, imageMetadata = metadata}) = + object $ + ["type" .= ("image" :: Text), "source_type" .= ("base64" :: Text), "data" .= imageData] + <> maybe [] (pure . ("metadata" .=)) metadata + toJSON (AudioBlock mime b64) = object ["type" .= ("audio" :: Text), "mime_type" .= mime, "data" .= b64] + toJSON (DataBlock bs) = object ["type" .= ("data" :: Text), "data" .= TE.decodeUtf8 (Base64.encode bs)] + +instance FromJSON ContentBlock where + parseJSON = withObject "ContentBlock" $ \v -> do + typ <- v .: "type" + case (typ :: Text) of + "text" -> TextBlock <$> v .: "text" + "image" -> do + mimeType <- v .:? "mime_type" + case mimeType of + Just mime -> do + imageData <- v .: "data" + metadata <- v .:? "metadata" + pure $ ImageBlock $ ImageContent (ImageBase64 (Just mime) imageData) Nothing metadata + Nothing -> do + sourceType <- v .: "source_type" + imageData <- v .: "data" + metadata <- v .:? "metadata" + let source = + case (sourceType :: Text) of + "url" -> ImageUrl imageData + _ -> ImageBase64 Nothing imageData + pure $ ImageBlock $ ImageContent source Nothing metadata + "image_url" -> do + imageUrl <- v .: "image_url" + url <- imageUrl .: "url" + detail <- imageUrl .:? "detail" + pure $ ImageBlock $ ImageContent (ImageUrl url) detail Nothing + "audio" -> AudioBlock <$> v .: "mime_type" <*> v .: "data" + "data" -> do + b64Text <- v .: "data" + case Base64.decode (TE.encodeUtf8 b64Text) of + Left err -> fail $ "Invalid base64 data block: " ++ err + Right bs -> pure $ DataBlock bs + other -> fail $ "Unknown ContentBlock type: " ++ show other + +-- | Complete set of conversation roles supported across LLM providers. +data Role + = System + | User + | Assistant + | Tool + | Developer + | Function + deriving (Eq, Ord, Show, Bounded, Enum, Generic, ToJSON, FromJSON) + +-- | Structured tool call from an LLM response. +data ToolCall = ToolCall + { toolCallId :: Text + , toolCallType :: Text + -- ^ Always "function" for current providers + , toolCallName :: Text + , toolCallArguments :: Value + -- ^ Parsed JSON Value arguments + } + deriving (Eq, Show, Generic, ToJSON, FromJSON) + +-- | Structured chat message supporting multi-modal content blocks. +data Message = Message + { messageRole :: Role + , messageContents :: NonEmpty ContentBlock + , messageName :: Maybe Text + , messageToolCalls :: Maybe [ToolCall] + , messageToolId :: Maybe Text + -- ^ Associated tool call ID for Tool role + , messageMetadata :: Map Text Value + -- ^ Opaque provider-specific metadata. + } + deriving (Eq, Show, Generic, ToJSON, FromJSON) + +-- | Create a message with a single text content block. +textMessage :: Role -> Text -> Message +textMessage r t = Message r (TextBlock t :| []) Nothing Nothing Nothing Map.empty + +-- | Create a User role text message. +userMessage :: Text -> Message +userMessage = textMessage User + +-- | Create a System role text message. +systemMessage :: Text -> Message +systemMessage = textMessage System + +-- | Create an Assistant role text message. +assistantMessage :: Text -> Message +assistantMessage = textMessage Assistant + +-- | Create a Tool role text message. +toolMessage :: Text -> Message +toolMessage = textMessage Tool + +-- | Create an Image content block message. +imageMessage :: Role -> Text -> Text -> Message +imageMessage r mime b64 = + Message + r + (ImageBlock (ImageContent (ImageBase64 (Just mime) b64) Nothing Nothing) :| []) + Nothing + Nothing + Nothing + Map.empty + +-- | Extract all text content blocks concatenated into a single Text string. +extractMessageText :: Message -> Text +extractMessageText msg = T.intercalate "\n" [t | TextBlock t <- NonEmpty.toList (messageContents msg)] + +-- | Label used when rendering a chat message role as plain text. +roleLabel :: Role -> Text +roleLabel System = "System" +roleLabel User = "Human" +roleLabel Assistant = "AI" +roleLabel Tool = "Tool" +roleLabel Developer = "Developer" +roleLabel Function = "Function" + +-- | Render a message as a single plain-text line with its role label. +formatMessageString :: Message -> Text +formatMessageString chatMessage = + roleLabel (messageRole chatMessage) <> ": " <> extractMessageText chatMessage diff --git a/src/Langchain/Monad.hs b/src/Langchain/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Monad.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE FlexibleContexts #-} + +{- | +Module : Langchain.Monad +Description : Core LangchainT monad transformer +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Provides the canonical monad transformer stack 'LangchainT' and its execution +runner 'runLangchainT'. + +'LangchainT' is parameterised over the reader environment @r@, so each +provider (or application) can supply its own config type rather than being +forced into a one-size-fits-all @LangchainConfig@. Use @r = ()@ when you do +not need a shared environment at all. + +@ +-- With a custom config +type App a = LangchainT MyConfig IO a + +runApp :: MyConfig -> App a -> IO (Either LangchainError a) +runApp = runLangchainT + +-- Without any config +runSimple :: LangchainT () IO a -> IO (Either LangchainError a) +runSimple = runLangchainT () +@ +-} +module Langchain.Monad + ( LangchainT + , runLangchainT + , throwLangchainError + ) where + +import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError) +import Control.Monad.Reader (ReaderT, runReaderT) + +import Langchain.Error (LangchainError) + +{- | Standard framework monad transformer stack: ReaderT over ExceptT. + +The type variable @r@ is the reader environment — pass your own provider +config, application context, or @()@ when none is needed. +-} +type LangchainT r m = ReaderT r (ExceptT LangchainError m) + +-- | Execute a 'LangchainT' computation with a given environment. +runLangchainT :: r -> LangchainT r m a -> m (Either LangchainError a) +runLangchainT env action = runExceptT (runReaderT action env) + +-- | Throw a 'LangchainError' inside any 'MonadError' context. +throwLangchainError :: MonadError LangchainError m => LangchainError -> m a +throwLangchainError = throwError diff --git a/src/Langchain/Observability.hs b/src/Langchain/Observability.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Observability.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.Observability +Description : Unified logging and OpenTelemetry tracing +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Provides unified structured logging and OpenTelemetry-compatible tracing. +-} +module Langchain.Observability + ( -- * Structured Logging + LogLevel (..) + , LogEvent (..) + , Logger (..) + , InMemoryLogger (..) + , newInMemoryLogger + , getInMemoryLogs + , stderrLogger + , logEvent + , logDebug + , logInfo + , logWarn + , logError + + -- * OpenTelemetry Tracing + , SpanKind (..) + , SpanStatus (..) + , Span (..) + , OTelTracer (..) + , newOTelTracer + , getSpans + , startSpan + , endSpan + , addSpanAttribute + , withSpan + , exportSpansJson + ) where + +import Control.Concurrent.STM +import Control.Monad (when) +import Control.Monad.Except (MonadError, catchError, throwError) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (FromJSON, ToJSON, encode) +import qualified Data.ByteString.Lazy.Char8 as LBSC +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) +import GHC.Generics (Generic) +import System.IO (hPutStrLn, stderr) +import System.Random (randomRIO) + +import Langchain.Error (LangchainError) + +-------------------------------------------------------------------------------- +-- Structured Logging +-------------------------------------------------------------------------------- + +-- | Severity level for log events +data LogLevel + = DebugLevel + | InfoLevel + | WarnLevel + | ErrorLevel + deriving (Show, Eq, Ord, Enum, Bounded, Generic, ToJSON, FromJSON) + +-- | Structured log event with metadata +data LogEvent = LogEvent + { logLevel :: !LogLevel + , logTimestamp :: !UTCTime + , logComponent :: !Text + , logMessage :: !Text + , logMetadata :: !(Map Text Text) + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | Pluggable logger backend +data Logger = Logger + { minLevel :: !LogLevel + , writeLog :: LogEvent -> IO () + } + +-- | In-memory logger storing events in STM TVar +data InMemoryLogger = InMemoryLogger + { inMemoryVar :: !(TVar [LogEvent]) + , inMemoryMinLevel :: !LogLevel + } + +-- | Construct a new InMemoryLogger +newInMemoryLogger :: MonadIO m => LogLevel -> m InMemoryLogger +newInMemoryLogger minLvl = liftIO $ do + var <- newTVarIO [] + pure $ InMemoryLogger var minLvl + +-- | Retrieve all logged events from an InMemoryLogger +getInMemoryLogs :: MonadIO m => InMemoryLogger -> m [LogEvent] +getInMemoryLogs InMemoryLogger {..} = liftIO $ readTVarIO inMemoryVar + +-- | Default stderr logger +stderrLogger :: LogLevel -> Logger +stderrLogger minLvl = + Logger + { minLevel = minLvl + , writeLog = \event -> do + let line = LBSC.unpack (encode event) + hPutStrLn stderr line + } + +-- | Log a structured event through a logger +logEvent :: MonadIO m => Logger -> LogLevel -> Text -> Text -> Map Text Text -> m () +logEvent Logger {..} lvl comp msg meta = + when (lvl >= minLevel) $ liftIO $ do + now <- getCurrentTime + let event = LogEvent lvl now comp msg meta + writeLog event + +-- | Log a debug message +logDebug :: MonadIO m => Logger -> Text -> Text -> m () +logDebug logger comp msg = logEvent logger DebugLevel comp msg Map.empty + +-- | Log an info message +logInfo :: MonadIO m => Logger -> Text -> Text -> m () +logInfo logger comp msg = logEvent logger InfoLevel comp msg Map.empty + +-- | Log a warning message +logWarn :: MonadIO m => Logger -> Text -> Text -> m () +logWarn logger comp msg = logEvent logger WarnLevel comp msg Map.empty + +-- | Log an error message +logError :: MonadIO m => Logger -> Text -> Text -> m () +logError logger comp msg = logEvent logger ErrorLevel comp msg Map.empty + +-------------------------------------------------------------------------------- +-- OpenTelemetry Tracing +-------------------------------------------------------------------------------- + +-- | OpenTelemetry Span Kind +data SpanKind + = InternalSpan + | ClientSpan + | ServerSpan + | ProducerSpan + | ConsumerSpan + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | OpenTelemetry Span Status +data SpanStatus + = StatusUnset + | StatusOk + | StatusError !Text + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | Single OpenTelemetry Span +data Span = Span + { spanName :: !Text + , spanTraceId :: !Text + , spanId :: !Text + , spanParentId :: !(Maybe Text) + , spanKind :: !SpanKind + , spanStartTime :: !UTCTime + , spanEndTime :: !(Maybe UTCTime) + , spanDurationMicros :: !(Maybe Int) + , spanAttributes :: !(Map Text Text) + , spanStatus :: !SpanStatus + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | Thread-safe in-memory OpenTelemetry tracer backed by STM TVar +data OTelTracer = OTelTracer + { tracerTraceId :: !Text + , tracerSpansVar :: !(TVar [Span]) + } + +-- | Construct a new OTelTracer with a given or auto-generated trace ID +newOTelTracer :: MonadIO m => Maybe Text -> m OTelTracer +newOTelTracer mbTraceId = liftIO $ do + tId <- case mbTraceId of + Just tid -> pure tid + Nothing -> do + randVal <- randomRIO (1000000000000000 :: Integer, 9999999999999999 :: Integer) + pure $ "trace-" <> T.pack (show randVal) + var <- newTVarIO [] + pure $ OTelTracer tId var + +-- | Retrieve all recorded spans +getSpans :: MonadIO m => OTelTracer -> m [Span] +getSpans OTelTracer {..} = liftIO $ readTVarIO tracerSpansVar + +-- | Start a new OpenTelemetry span +startSpan :: + MonadIO m => + OTelTracer -> + Text -> + Maybe Text -> + SpanKind -> + Map Text Text -> + m Span +startSpan OTelTracer {..} name parentId kind attrs = liftIO $ do + now <- getCurrentTime + randSpan <- randomRIO (10000000 :: Integer, 99999999 :: Integer) + let sId = "span-" <> T.pack (show randSpan) + sp = + Span + { spanName = name + , spanTraceId = tracerTraceId + , spanId = sId + , spanParentId = parentId + , spanKind = kind + , spanStartTime = now + , spanEndTime = Nothing + , spanDurationMicros = Nothing + , spanAttributes = attrs + , spanStatus = StatusUnset + } + atomically $ modifyTVar' tracerSpansVar (\spans -> spans ++ [sp]) + pure sp + +-- | Complete an active span with final status +endSpan :: MonadIO m => OTelTracer -> Text -> SpanStatus -> m () +endSpan OTelTracer {..} targetSpanId status = liftIO $ do + now <- getCurrentTime + atomically $ modifyTVar' tracerSpansVar (map (finalizeSpan now)) + where + finalizeSpan now sp + | spanId sp == targetSpanId = + let durMicros = round (diffUTCTime now (spanStartTime sp) * 1000000) + in sp + { spanEndTime = Just now + , spanDurationMicros = Just durMicros + , spanStatus = status + } + | otherwise = sp + +-- | Add or update an attribute on an active or completed span +addSpanAttribute :: MonadIO m => OTelTracer -> Text -> Text -> Text -> m () +addSpanAttribute OTelTracer {..} targetSpanId key val = liftIO $ do + atomically $ modifyTVar' tracerSpansVar (map updateAttr) + where + updateAttr sp + | spanId sp == targetSpanId = + sp {spanAttributes = Map.insert key val (spanAttributes sp)} + | otherwise = sp + +-- | Wrap a monadic computation within an OpenTelemetry span +withSpan :: + (MonadIO m, MonadError LangchainError m) => + OTelTracer -> + Text -> + Maybe Text -> + SpanKind -> + Map Text Text -> + m a -> + m a +withSpan tracer name parentId kind attrs action = do + sp <- startSpan tracer name parentId kind attrs + res <- + action `catchError` \err -> do + endSpan tracer (spanId sp) (StatusError (T.pack (show err))) + throwError err + endSpan tracer (spanId sp) StatusOk + pure res + +-- | Export all recorded spans as JSON ByteString +exportSpansJson :: MonadIO m => OTelTracer -> m Text +exportSpansJson tracer = do + spans <- getSpans tracer + pure $ T.pack $ LBSC.unpack $ encode spans diff --git a/src/Langchain/OutputParser.hs b/src/Langchain/OutputParser.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/OutputParser.hs @@ -0,0 +1,18 @@ +{- | +Module : Langchain.OutputParser +Description : Output parsers and structured data extraction +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Output parsers to transform raw LLM text into structured formats including +lists, JSON, and typed Haskell data structures via JSON Schema generation. +-} +module Langchain.OutputParser + ( module Langchain.OutputParser.Core + , module Langchain.OutputParser.Structured + ) where + +import Langchain.OutputParser.Core +import Langchain.OutputParser.Structured diff --git a/src/Langchain/OutputParser/Core.hs b/src/Langchain/OutputParser/Core.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/OutputParser/Core.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module: Langchain.OutputParser.Core +Copyright: (c) 2025-2026 Tushar Adhatrao +License: MIT +Maintainer: Tushar Adhatrao +Stability: experimental + +Core output parser typeclass and standard instances for basic text transformations. +For typed JSON and schema-driven parsing, see "Langchain.OutputParser.Structured". +-} +module Langchain.OutputParser.Core + ( -- * Typeclass + OutputParser (..) + + -- * Parsers + , CommaSeparatedList (..) + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Text.Read as TR + +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 -> LangchainResult a + +-- | Identity parser returning the raw text output unchanged. +instance OutputParser Text where + parse = Right + +{- | Parse a boolean value from text using case-insensitive normalization. + +Accepts @"true"@, @"t"@, @"yes"@, @"1"@ as 'True', and @"false"@, @"f"@, @"no"@, @"0"@ as 'False'. +-} +instance OutputParser Bool where + parse txt = + case T.toLower (T.strip txt) of + "true" -> Right True + "t" -> Right True + "yes" -> Right True + "1" -> Right True + "false" -> Right False + "f" -> Right False + "no" -> Right False + "0" -> Right False + _ -> Left $ parsingError "Invalid boolean value" (Just "Bool") (Just txt) + +-- | Represents a list of text items separated by commas. +newtype CommaSeparatedList = CommaSeparatedList [Text] + deriving (Show, Eq) + +instance OutputParser CommaSeparatedList where + parse txt = Right $ CommaSeparatedList $ map T.strip $ T.splitOn "," txt + +-- | Parse an 'Int' value from trimmed text output. +instance OutputParser Int where + parse txt = + case TR.readMaybe (T.unpack (T.strip txt)) of + Just n -> Right n + Nothing -> Left $ parsingError "Failed to parse Int from output" (Just "Int") (Just txt) + +-- | Parse an 'Integer' value from trimmed text output. +instance OutputParser Integer where + parse txt = + case TR.readMaybe (T.unpack (T.strip txt)) of + Just n -> Right n + Nothing -> Left $ parsingError "Failed to parse Integer from output" (Just "Integer") (Just txt) + +-- | Parse a 'Double' value from trimmed text output. +instance OutputParser Double where + parse txt = + case TR.readMaybe (T.unpack (T.strip txt)) of + Just n -> Right n + Nothing -> Left $ parsingError "Failed to parse Double from output" (Just "Double") (Just txt) diff --git a/src/Langchain/OutputParser/Structured.hs b/src/Langchain/OutputParser/Structured.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/OutputParser/Structured.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +{- | +Module : Langchain.OutputParser.Structured +Description : Type-safe structured output extraction using GHC Generics and JSON Schemas +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Generates JSON Schemas automatically from Haskell types using GHC Generics, +prompts the ChatModel for structured JSON output, and parses the response into typed values +with an automatic error-correction retry loop. +-} +module Langchain.OutputParser.Structured + ( StructuredOutput (..) + , TypeSchema (..) + , GRecordSchema (..) + , genericJsonSchema + , structuredInvoke + , structuredInvokeWithRetries + , extractJsonFromMarkdown + ) where + +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.IO.Class (MonadIO) +import Data.Aeson (FromJSON, Value (..), decode, encode, object, (.=)) +import qualified Data.Aeson.Key as Key +import qualified Data.ByteString.Lazy.Char8 as LBSC +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) +import qualified Data.Map.Strict as Map +import Data.Proxy (Proxy (..)) +import Data.Scientific (Scientific) +import Data.Text (Text) +import qualified Data.Text as TS +import qualified Data.Text.Encoding as TE +import Data.Time (Day, UTCTime) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Generics + +import Langchain.Error (LangchainError, parsingError) +import Langchain.Model + ( ChatModel (..) + , Message (..) + , extractMessageText + , systemMessage + , userMessage + ) + +-- | Typeclass for types that declare a JSON Schema and structured parser +class (FromJSON a) => StructuredOutput a where + outputSchema :: Proxy a -> Value + default outputSchema :: (GRecordSchema (Rep a)) => Proxy a -> Value + outputSchema _ = genericJsonSchema (Proxy :: Proxy a) + +-- | Generic JSON Schema derivation helper +genericJsonSchema :: forall a. (GRecordSchema (Rep a)) => Proxy a -> Value +genericJsonSchema _ = + let (props, reqs) = gRecordSchema (Proxy :: Proxy (Rep a)) + in object + [ "type" .= ("object" :: Text) + , "properties" .= object props + , "required" .= reqs + ] + +-- | Generic record schema inspector for deriving JSON Schemas. +class GRecordSchema (f :: Type -> Type) where + gRecordSchema :: Proxy f -> ([(Key.Key, Value)], [Text]) + +instance (GRecordSchema f, GRecordSchema g) => GRecordSchema (f :*: g) where + gRecordSchema _ = + let (p1, r1) = gRecordSchema (Proxy :: Proxy f) + (p2, r2) = gRecordSchema (Proxy :: Proxy g) + in (p1 ++ p2, r1 ++ r2) + +instance (GRecordSchema f) => GRecordSchema (M1 D c f) where + gRecordSchema _ = gRecordSchema (Proxy :: Proxy f) + +instance (GRecordSchema f) => GRecordSchema (M1 C c f) where + gRecordSchema _ = gRecordSchema (Proxy :: Proxy f) + +instance (Selector s, TypeSchema a) => GRecordSchema (M1 S s (K1 R a)) where + gRecordSchema _ = + let selNameStr = selName (undefined :: M1 S s (K1 R a) p) + propKey = Key.fromString selNameStr + propSchema = typeJsonSchema (Proxy :: Proxy a) + req = [TS.pack selNameStr | not (isOptionalType (Proxy :: Proxy a))] + in ([(propKey, propSchema)], req) + +-- | Typeclass defining JSON Schema mapping for Haskell primitive and composite types +class TypeSchema a where + typeJsonSchema :: Proxy a -> Value + default typeJsonSchema :: (GRecordSchema (Rep a)) => Proxy a -> Value + typeJsonSchema _ = genericJsonSchema (Proxy :: Proxy a) + + isOptionalType :: Proxy a -> Bool + isOptionalType _ = False + +instance (TypeSchema a) => TypeSchema (Maybe a) where + typeJsonSchema _ = typeJsonSchema (Proxy :: Proxy a) + isOptionalType _ = True + +instance TypeSchema Text where + typeJsonSchema _ = object ["type" .= ("string" :: Text)] + +instance TypeSchema String where + typeJsonSchema _ = object ["type" .= ("string" :: Text)] + +instance TypeSchema Char where + typeJsonSchema _ = object ["type" .= ("string" :: Text)] + +instance TypeSchema Int where + typeJsonSchema _ = object ["type" .= ("integer" :: Text)] + +instance TypeSchema Int8 where + typeJsonSchema _ = object ["type" .= ("integer" :: Text)] + +instance TypeSchema Int16 where + typeJsonSchema _ = object ["type" .= ("integer" :: Text)] + +instance TypeSchema Int32 where + typeJsonSchema _ = object ["type" .= ("integer" :: Text)] + +instance TypeSchema Int64 where + typeJsonSchema _ = object ["type" .= ("integer" :: Text)] + +instance TypeSchema Integer where + typeJsonSchema _ = object ["type" .= ("integer" :: Text)] + +instance TypeSchema Word where + typeJsonSchema _ = object ["type" .= ("integer" :: Text)] + +instance TypeSchema Word8 where + typeJsonSchema _ = object ["type" .= ("integer" :: Text)] + +instance TypeSchema Word16 where + typeJsonSchema _ = object ["type" .= ("integer" :: Text)] + +instance TypeSchema Word32 where + typeJsonSchema _ = object ["type" .= ("integer" :: Text)] + +instance TypeSchema Word64 where + typeJsonSchema _ = object ["type" .= ("integer" :: Text)] + +instance TypeSchema Double where + typeJsonSchema _ = object ["type" .= ("number" :: Text)] + +instance TypeSchema Float where + typeJsonSchema _ = object ["type" .= ("number" :: Text)] + +instance TypeSchema Scientific where + typeJsonSchema _ = object ["type" .= ("number" :: Text)] + +instance TypeSchema Bool where + typeJsonSchema _ = object ["type" .= ("boolean" :: Text)] + +instance TypeSchema UTCTime where + typeJsonSchema _ = + object + [ "type" .= ("string" :: Text) + , "format" .= ("date-time" :: Text) + ] + +instance TypeSchema Day where + typeJsonSchema _ = + object + [ "type" .= ("string" :: Text) + , "format" .= ("date" :: Text) + ] + +instance TypeSchema Value where + typeJsonSchema _ = object ["type" .= ("object" :: Text)] + +instance (TypeSchema a) => TypeSchema (Map.Map Text a) where + typeJsonSchema _ = + object + [ "type" .= ("object" :: Text) + , "additionalProperties" .= typeJsonSchema (Proxy :: Proxy a) + ] + +instance {-# OVERLAPPABLE #-} (TypeSchema a) => TypeSchema [a] where + typeJsonSchema _ = + object + [ "type" .= ("array" :: Text) + , "items" .= typeJsonSchema (Proxy :: Proxy a) + ] + +{- | Invoke a 'ChatModel' and extract a typed 'StructuredOutput' value. + +This function injects the JSON Schema into a system prompt and parses the LLM's response, +retrying up to 3 times with error feedback if parsing fails. + +__Provider-Specific Grammar Enforcement:__ +Note that 'structuredInvoke' relies on prompt-based instructions and schema validation across +generic 'ChatModel' instances. For strict token-level schema enforcement with Ollama, use +@withStructuredOutput@ from @langchain-hs-ollama@. +-} +structuredInvoke :: + forall a model m. + (StructuredOutput a, ChatModel model, MonadIO m, MonadError LangchainError m) => + model -> + [Message] -> + m a +structuredInvoke model msgs = structuredInvokeWithRetries model msgs 3 + +-- | Invoke a ChatModel with up to N retry iterations with error-correction feedback +structuredInvokeWithRetries :: + forall a model m. + (StructuredOutput a, ChatModel model, MonadIO m, MonadError LangchainError m) => + model -> + [Message] -> + Int -> + m a +structuredInvokeWithRetries model baseMsgs maxAttempts = do + let schema = outputSchema (Proxy :: Proxy a) + schemaStr = TE.decodeUtf8 $ LBSC.toStrict $ encode schema + systemInstruction = + systemMessage + ( "You are a structured data extractor. You must respond ONLY with a valid JSON object matching this JSON Schema:\n" + <> schemaStr + <> "\nDo NOT wrap the JSON in Markdown backticks or provide conversational text." + ) + fullConversation = systemInstruction : baseMsgs + go fullConversation maxAttempts + where + go conv attemptsLeft = do + resp <- invoke model conv Nothing + let rawText = extractMessageText resp + cleanJson = extractJsonFromMarkdown rawText + bs = LBSC.fromStrict (TE.encodeUtf8 cleanJson) + case decode bs of + Just parsedVal -> pure parsedVal + Nothing -> + if attemptsLeft <= 1 + then + throwError $ + parsingError + ( "Failed to parse structured JSON output from LLM: " + <> rawText + <> " (Schema: " + <> TE.decodeUtf8 (LBSC.toStrict (encode (outputSchema (Proxy :: Proxy a)))) + <> ")" + ) + (Just "structuredInvoke") + Nothing + else do + let correctionMsg = + userMessage + ( "Your previous response was not valid JSON matching the schema. Error: failed to parse.\n" + <> "Please re-output ONLY valid JSON matching the schema." + ) + updatedConv = conv ++ [resp, correctionMsg] + go updatedConv (attemptsLeft - 1) + +-- | Robust helper to unwrap JSON from markdown ```json ``` blocks +extractJsonFromMarkdown :: Text -> Text +extractJsonFromMarkdown t = + let stripped = TS.strip t + in if "```json" `TS.isPrefixOf` stripped + then + let afterPrefix = TS.drop 7 stripped + in case TS.breakOn "```" afterPrefix of + (jsonPart, _) -> TS.strip jsonPart + else + if "```" `TS.isPrefixOf` stripped + then + let afterPrefix = TS.drop 3 stripped + in case TS.breakOn "```" afterPrefix of + (jsonPart, _) -> TS.strip jsonPart + else stripped diff --git a/src/Langchain/Prelude.hs b/src/Langchain/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Prelude.hs @@ -0,0 +1,382 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} + +{- | +Module : Langchain.Prelude +Description : Canonical umbrella re-export module for langchain-hs-core +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Exports all core data types, typeclasses, vector stores, memory stores, +advanced agents, guardrails, observability, structured logging, +circuit breakers, callbacks, output parsers, and pipeline DSLs. +-} +module Langchain.Prelude + ( -- * Core Monad & Errors + LangchainT + , runLangchainT + , throwLangchainError + , LangchainError (..) + , ErrorContext (..) + , errorMessage + , mkContext + , mkContextIO + , LangchainResult + , llmError + , parsingError + , vectorStoreError + , documentLoaderError + , embeddingError + , runnableError + , toolError + , agentError + , memoryError + , networkError + , configurationError + , validationError + , internalError + + -- * Multi-Modal Models & Messages + , ChatModel (..) + , Message (..) + , Role + , ContentBlock (..) + , ToolCall (..) + , textMessage + , userMessage + , systemMessage + , assistantMessage + , toolMessage + , imageMessage + , extractMessageText + , StreamEvent + ( LLMStart + , LLMChunk + , LLMEnd + , ToolStart + , ToolEnd + , ToolErrorEvent + , ChainStart + , ChainEnd + , NodeStart + , NodeEnd + ) + , TokenUsage (..) + , EventStream + , collectEvents + , printEvents + + -- * Pure AST Pipelines (RunnableTree) + , RunnableTree (..) + , (|>>) + , (&>&) + , interpret + , runLambda + , runPrim + , runPure + , runPassthrough + , runIdent + , runBranch + , runFallback + , runChat + , runChatWithConfig + , runModel + , runModelWithConfig + , runConfiguredModel + , runRetriever + , ModelRunnable (..) + , modelRunnable + , modelRunnableWithConfig + , bindConfig + , TextModelRunnable (..) + , textModelRunnable + , textModelRunnableWithConfig + , bindTextConfig + , ConfiguredModelRunnable (..) + + -- * Effect-Polymorphic Tools + , Tool (..) + , createTool + , toolToValue + , ToolBinder (..) + , DeriveToolSchema (..) + , deriveToolParametersSchema + + -- * Advanced Agent Patterns + , PlanStep (..) + , Plan (..) + , StepExecutor (..) + , PlanAndExecuteAgent (..) + , newPlanAndExecuteAgent + , newPlanAndExecuteAgentWithTools + , runPlanAndExecute + + -- * Guardrails & Safety + , GuardrailResult (..) + , Guardrail (..) + , contentSafetyGuardrail + , topicGuardrail + , outputLengthGuardrail + , composeGuardrails + , withGuardrails + + -- * Telemetry, Logging & OpenTelemetry + , LogLevel (..) + , LogEvent (..) + , Logger (..) + , InMemoryLogger (..) + , newInMemoryLogger + , getInMemoryLogs + , stderrLogger + , logEvent + , logDebug + , logInfo + , logWarn + , logError + , SpanKind (..) + , SpanStatus (..) + , Span (..) + , OTelTracer (..) + , newOTelTracer + , getSpans + , startSpan + , endSpan + , addSpanAttribute + , withSpan + , exportSpansJson + + -- * Callbacks + , CallbackEvent (..) + , CallbackHandler (..) + , CallbackManager (..) + , newCallbackManager + , registerHandler + , dispatchEvent + , dispatchEventAsync + , newLoggingCallbackHandler + , getCallbackLogs + + -- * Resilience + , CircuitState (..) + , CircuitBreakerConfig (..) + , defaultCircuitConfig + , CircuitBreaker (..) + , newCircuitBreaker + , getCircuitState + , withCircuitBreaker + + -- * Memory Systems + , BaseMemory (..) + , SomeMemory (..) + , ConversationBufferMemory (..) + , newConversationBufferMemory + , resetConversationBuffer + , WindowBufferMemory (..) + , newWindowBufferMemory + , resetWindowBuffer + , TokenBufferMemory (..) + , newTokenBufferMemory + , resetTokenBuffer + , countTokens + , SummaryMemory (..) + , newSummaryMemory + , SessionId + , SessionMemoryStore (..) + , newSessionMemoryStore + , newSessionMemoryStoreWithTTL + , getSessionMemory + , listSessions + , hasSession + , deleteSession + , clearAllSessions + , sessionCount + , cleanupExpiredSessions + , exportAllSessions + , EntityMemory (..) + , newEntityMemory + , setEntity + , getEntity + , getAllEntities + , deleteEntity + , clearEntities + , formatEntities + , resetEntitiesToInitial + , CombinedMemory (..) + , newCombinedMemory + , initialMessages + , trimMessages + , resetToInitial + + -- * Vector Stores & Retrieval + , VectorStore (..) + , InMemory (..) + , emptyInMemoryVectorStore + , fromDocuments + , Retriever (..) + , VectorStoreRetriever (..) + , retrieveWithCallbacks + + -- * Embeddings (provider-agnostic typeclass) + , Embeddings (..) + + -- * Document Loaders + , Document (..) + , BaseLoader (..) + , FileLoader (..) + , DirectoryLoader (..) + , DirectoryLoaderOptions (..) + , defaultDirectoryLoaderOptions + , splitDocuments + + -- * Prompt Templates + , PromptTemplate (..) + , PromptTemplateOptions (..) + , TemplateFormat (..) + , defaultPromptTemplateOptions + , fromTemplate + , fromTemplateWithOptions + , fromTemplateWithFormat + , partialPromptTemplate + , renderPrompt + + -- * Text Splitters + , CharacterSplitterOps (CharacterSplitterOps) + , defaultCharacterSplitterOps + , splitText + , RecursiveCharacterSplitterOps (RecursiveCharacterSplitterOps) + , defaultRecursiveCharacterSplitterOps + , splitTextRecursive + , MarkdownSplitterOps (MarkdownSplitterOps) + , defaultMarkdownSplitterOps + , splitMarkdown + , splitMarkdownToChunks + , TokenSplitterOps (TokenSplitterOps) + , defaultTokenSplitterOps + , splitByTokens + , Language (..) + , CodeSplitterOps (CodeSplitterOps) + , splitCode + + -- * Caching & Resilience + , CacheBackend (..) + , InMemoryCache (..) + , newInMemoryCache + , SQLiteCache (..) + , newSQLiteCache + , CachedModel (..) + , CacheableChatModel (..) + , withCaching + , RetryPolicy (RetryPolicy) + , defaultRetryPolicy + , withRetry + , RateLimiter (..) + , newRateLimiter + , withRateLimit + + -- * Chains + , RetrievalQA (RetrievalQA) + , newRetrievalQA + , runRetrievalQA + + -- * Structured Output & Parsers + , OutputParser (..) + , CommaSeparatedList (..) + , StructuredOutput (..) + , TypeSchema (..) + , structuredInvoke + , structuredInvokeWithRetries + + -- * Agents & Execution + , ReActAgent (ReActAgent) + , AgentStep (..) + , AgentTrace (..) + , ToolErrorStrategy (..) + , defaultReActAgent + , withMemory + , withoutMemory + , withSystemPrompt + , withMaxIterations + , withModelConfig + , withCallbackManager + , withStopCondition + , withToolErrorStrategy + , reactStep + , runReActAgent + , runReActAgentWithTrace + + -- * Tool Suite & Security + , ToolTier (..) + , SecurityPolicy (..) + , defaultSecurityPolicy + , readOnlySecurityPolicy + , workspaceSandboxPolicy + , withSecurity + , newFileSystemSuite + , findFilesTool + , grepSearchTool + , readFileTool + , listDirTool + , editFileTool + , writeFileTool + , newProcessSuite + , commandRunTool + , commandStatusTool + , commandKillTool + , shellTool + + -- * Hybrid Retrieval & BM25 + , BM25Index (..) + , newBM25Index + , newBM25IndexWithParams + , addDocumentsBM25 + , bm25Search + , bm25SearchWithScores + , HybridRetriever (..) + , newHybridRetriever + , newHybridRetrieverWithWeights + , searchHybrid + , searchHybridWithScores + , reciprocalRankFusion + ) where + +import Langchain.Agent.PlanAndExecute +import Langchain.Agent.ReAct +import Langchain.Cache.Core +import Langchain.Callback.Manager +import Langchain.Chain.RetrievalQA +import Langchain.DocumentLoader.Core +import Langchain.DocumentLoader.DirectoryLoader +import Langchain.DocumentLoader.FileLoader +import Langchain.Embeddings.Core +import Langchain.Error +import Langchain.Guardrail.Core +import Langchain.Memory +import Langchain.Model +import Langchain.Monad +import Langchain.Observability +import Langchain.OutputParser.Core +import Langchain.OutputParser.Structured +import Langchain.PromptTemplate.Prompt +import Langchain.Resilience.CircuitBreaker +import Langchain.Resilience.Retry +import Langchain.Retriever.BM25 +import Langchain.Retriever.Core +import Langchain.Retriever.Hybrid +import Langchain.Runnable hiding (invoke) +import Langchain.Stream +import Langchain.TextSplitter.Character +import Langchain.TextSplitter.Code +import Langchain.TextSplitter.Markdown +import Langchain.TextSplitter.RecursiveCharacter +import Langchain.TextSplitter.Token +import Langchain.Tool +import Langchain.Tool.Binding +import Langchain.Tool.FileSystem +import Langchain.Tool.GenericSchema +import Langchain.Tool.Process +import Langchain.Tool.Security +import Langchain.Tool.Shell (shellTool) +import Langchain.VectorStore.Core +import Langchain.VectorStore.InMemory diff --git a/src/Langchain/PromptTemplate.hs b/src/Langchain/PromptTemplate.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/PromptTemplate.hs @@ -0,0 +1,17 @@ +{- | +Module : Langchain.PromptTemplate +Description : Prompt templates and variable interpolation +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +String-based prompt templates with variable interpolation and Runnable integration. +-} +module Langchain.PromptTemplate + ( module Langchain.PromptTemplate.Prompt + , module Langchain.PromptTemplate.String + ) where + +import Langchain.PromptTemplate.Prompt +import Langchain.PromptTemplate.String diff --git a/src/Langchain/PromptTemplate/Prompt.hs b/src/Langchain/PromptTemplate/Prompt.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/PromptTemplate/Prompt.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module : Langchain.PromptTemplate.Prompt +Description : String prompt templates +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Prompt templates backed by string interpolation. +-} +module Langchain.PromptTemplate.Prompt + ( PromptTemplate (..) + , PromptTemplateOptions (..) + , TemplateFormat (..) + , defaultPromptTemplateOptions + , fromTemplate + , fromTemplateWithOptions + , fromTemplateWithFormat + , partialPromptTemplate + , renderPrompt + , renderTemplateWithFormat + , renderFStringTemplate + , extractTemplateVariables + , extractTemplateVariablesWithFormat + ) where + +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import GHC.Generics (Generic) + +import Langchain.Error (LangchainError) +import Langchain.PromptTemplate.String + ( TemplateFormat (..) + , extractTemplateVariables + , extractTemplateVariablesWithFormat + , renderFStringTemplate + , renderTemplateWithFormat + ) +import Langchain.Runnable (Runnable (..)) + +-- | Prompt template container with template string containing {var} placeholders. +data PromptTemplate = PromptTemplate + { template :: Text + , inputVariables :: [Text] + , -- Matches Python partial_variables: pre-bound values reduce required inputs + -- without changing the original template string. + partialVariables :: Map.Map Text Text + , templateFormat :: TemplateFormat + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | Options for building a prompt template, currently only partial variables. +newtype PromptTemplateOptions = PromptTemplateOptions + { partialVariables :: Map.Map Text Text + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | Default prompt template options with no partial variables. +defaultPromptTemplateOptions :: PromptTemplateOptions +defaultPromptTemplateOptions = PromptTemplateOptions mempty + +-- | Build a string prompt template using the default FString format. +fromTemplate :: Text -> PromptTemplate +fromTemplate source = fromTemplateWithOptions source defaultPromptTemplateOptions + +-- | Build a string prompt template with pre-bound partial variables. +fromTemplateWithOptions :: Text -> PromptTemplateOptions -> PromptTemplate +fromTemplateWithOptions source (PromptTemplateOptions partials) = + fromTemplateWithFormat source FString partials + +-- | Build a prompt template from raw text, format, and partial variables. +fromTemplateWithFormat :: Text -> TemplateFormat -> Map.Map Text Text -> PromptTemplate +fromTemplateWithFormat source format partials = + PromptTemplate + { template = source + , inputVariables = + filter (`Map.notMember` partials) (extractTemplateVariablesWithFormat format source) + , partialVariables = partials + , templateFormat = format + } + +-- | Apply additional partial variables to an existing prompt template. +partialPromptTemplate :: PromptTemplate -> Map.Map Text Text -> PromptTemplate +partialPromptTemplate (PromptTemplate source _ existingPartials format) partials = + fromTemplateWithFormat source format (partials `Map.union` existingPartials) + +-- | Render a prompt template with the given variable map. +renderPrompt :: PromptTemplate -> Map.Map Text Text -> Either LangchainError Text +renderPrompt (PromptTemplate source _ partials format) vars = + renderTemplateWithFormat format (vars `Map.union` partials) source + +-- | t'PromptTemplate' implements 'Runnable' transforming variable @Map@ to rendered 'Text'. +instance Monad m => Runnable PromptTemplate m where + type RunnableInput PromptTemplate = Map.Map Text Text + type RunnableOutput PromptTemplate = Text + invoke pt vars = pure (renderPrompt pt vars) diff --git a/src/Langchain/PromptTemplate/String.hs b/src/Langchain/PromptTemplate/String.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/PromptTemplate/String.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Langchain.PromptTemplate.String +Description : String prompt template formatting helpers +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +String template parsing, variable extraction, and interpolation helpers. +-} +module Langchain.PromptTemplate.String + ( TemplateFormat (..) + , renderTemplateWithFormat + , renderFStringTemplate + , extractTemplateVariables + , extractTemplateVariablesWithFormat + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Char (isDigit) +import Data.Foldable (traverse_) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Format.Heavy.Build (formatEither) +import Data.Text.Format.Heavy.Instances () +import Data.Text.Format.Heavy.Parse (FormatParseItem (..), parse, parseFormat) +import qualified Data.Text.Lazy as TL +import GHC.Generics (Generic) + +import Langchain.Error (LangchainError, validationError) + +-- | Template format specification. +data TemplateFormat + = -- | Python-style f-string formatting using @{variable}@ placeholders. + FString + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | Render a template string using the specified 'TemplateFormat'. +renderTemplateWithFormat :: + TemplateFormat -> Map.Map Text Text -> Text -> Either LangchainError Text +renderTemplateWithFormat FString = renderFStringTemplate + +-- | Render a Python-style f-string template using provided variable mappings. +renderFStringTemplate :: Map.Map Text Text -> Text -> Either LangchainError Text +renderFStringTemplate vars source = do + items <- parseFStringTemplate source + traverse_ validateFStringItem items + format <- mapParseError $ parseFormat (TL.fromStrict source) + mapFormatError $ TL.toStrict <$> formatEither format (toFStringVars vars) + where + mapFormatError :: Either String a -> Either LangchainError a + mapFormatError (Left err) = Left $ validationError (T.pack err) (Just "PromptTemplate") Nothing + mapFormatError (Right result) = Right result + +toFStringVars :: Map.Map Text Text -> Map.Map TL.Text Text +toFStringVars = Map.mapKeys TL.fromStrict + +parseFStringTemplate :: Text -> Either LangchainError [FormatParseItem] +parseFStringTemplate source = mapParseError $ parse (TL.fromStrict source) + +mapParseError :: (Show err) => Either err a -> Either LangchainError a +mapParseError (Left err) = Left $ validationError (T.pack $ show err) (Just "PromptTemplate") Nothing +mapParseError (Right result) = Right result + +validateFStringItem :: FormatParseItem -> Either LangchainError () +validateFStringItem (FormatString _) = Right () +validateFStringItem (FormatReplacementField variableName formatSpec) = do + validateFStringVariableName variableName + traverse_ validateFStringFormatSpec formatSpec + +validateFStringVariableName :: TL.Text -> Either LangchainError () +validateFStringVariableName variableName + | TL.all isDigit variableName = + Left $ + validationError "Positional arguments are not supported" (Just $ TL.toStrict variableName) Nothing + | TL.any (== '.') variableName = + Left $ validationError "Attribute access is not supported" (Just $ TL.toStrict variableName) Nothing + | TL.any (`elem` ['[', ']']) variableName = + Left $ validationError "Index access is not supported" (Just $ TL.toStrict variableName) Nothing + | otherwise = Right () + +validateFStringFormatSpec :: TL.Text -> Either LangchainError () +validateFStringFormatSpec formatSpec + | TL.any (`elem` ['{', '}']) formatSpec = + Left $ validationError "Nested replacement fields are not allowed" (Just "PromptTemplate") Nothing + | otherwise = Right () + +-- | Extract variable names present in an f-string template. +extractTemplateVariables :: Text -> [Text] +extractTemplateVariables = extractTemplateVariablesWithFormat FString + +-- | Extract variable names present in a template of the given 'TemplateFormat'. +extractTemplateVariablesWithFormat :: TemplateFormat -> Text -> [Text] +extractTemplateVariablesWithFormat FString source = + case parseFStringTemplate source of + Left _ -> [] + Right parts -> unique [TL.toStrict variableName | FormatReplacementField variableName _ <- parts] + +unique :: [Text] -> [Text] +unique = foldl addIfMissing [] + +addIfMissing :: [Text] -> Text -> [Text] +addIfMissing variableNames variableName + | variableName `elem` variableNames = variableNames + | otherwise = variableNames <> [variableName] diff --git a/src/Langchain/Resilience.hs b/src/Langchain/Resilience.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Resilience.hs @@ -0,0 +1,18 @@ +{- | +Module : Langchain.Resilience +Description : Resilience patterns for LLM invocations and tool calls +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Resilience combinators including exponential backoff retries, token-bucket rate limiting, +and circuit breakers for fault-tolerant LLM pipelines. +-} +module Langchain.Resilience + ( module Langchain.Resilience.CircuitBreaker + , module Langchain.Resilience.Retry + ) where + +import Langchain.Resilience.CircuitBreaker +import Langchain.Resilience.Retry diff --git a/src/Langchain/Resilience/CircuitBreaker.hs b/src/Langchain/Resilience/CircuitBreaker.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Resilience/CircuitBreaker.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.Resilience.CircuitBreaker +Description : Circuit breaker pattern for LLM provider failover and graceful degradation +Copyright : (c) 2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Implements the Circuit Breaker pattern (Closed, Open, HalfOpen) to prevent cascading failures +when upstream LLM APIs or vector stores experience outages. +-} +module Langchain.Resilience.CircuitBreaker + ( CircuitState (..) + , CircuitBreakerConfig (..) + , defaultCircuitConfig + , CircuitBreaker (..) + , newCircuitBreaker + , getCircuitState + , withCircuitBreaker + ) where + +import Control.Concurrent.STM +import Control.Monad.Except (MonadError, catchError, throwError) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) +import GHC.Generics (Generic) + +import Langchain.Error (LangchainError, internalError) + +-- | State of the circuit breaker +data CircuitState + = CircuitClosed + | CircuitOpen !UTCTime -- Timestamp when opened + | CircuitHalfOpen + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | Configuration parameters for the circuit breaker +data CircuitBreakerConfig = CircuitBreakerConfig + { failureThreshold :: !Int + , resetTimeoutSec :: !Double + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-- | Sensible default configuration (5 failures to open, 30 seconds reset timeout) +defaultCircuitConfig :: CircuitBreakerConfig +defaultCircuitConfig = + CircuitBreakerConfig + { failureThreshold = 5 + , resetTimeoutSec = 30.0 + } + +-- | Circuit breaker handle backed by STM TVar +data CircuitBreaker = CircuitBreaker + { circuitName :: !Text + , circuitConfig :: !CircuitBreakerConfig + , circuitStateVar :: !(TVar (CircuitState, Int)) -- (State, consecutive failures) + } + +-- | Construct a new CircuitBreaker +newCircuitBreaker :: MonadIO m => Text -> CircuitBreakerConfig -> m CircuitBreaker +newCircuitBreaker name cfg = liftIO $ do + var <- newTVarIO (CircuitClosed, 0) + pure $ CircuitBreaker name cfg var + +-- | Query current state of the circuit breaker +getCircuitState :: MonadIO m => CircuitBreaker -> m CircuitState +getCircuitState CircuitBreaker {..} = liftIO $ do + (st, _) <- readTVarIO circuitStateVar + pure st + +-- | Execute a protected action through the circuit breaker +withCircuitBreaker :: + (MonadIO m, MonadError LangchainError m) => + CircuitBreaker -> + m a -> + m a +withCircuitBreaker CircuitBreaker {..} action = do + now <- liftIO getCurrentTime + canProceed <- liftIO $ atomically $ do + (st, _) <- readTVar circuitStateVar -- Only the state is needed to gate; count is managed in the error handler below + case st of + CircuitClosed -> pure True + CircuitHalfOpen -> pure True + CircuitOpen openTime -> + if diffUTCTime now openTime >= realToFrac (resetTimeoutSec circuitConfig) + then do + writeTVar circuitStateVar (CircuitHalfOpen, 0) + pure True + else pure False + + if not canProceed + then + throwError $ + internalError + ("Circuit breaker '" <> circuitName <> "' is OPEN. Fast-failing request.") + (Just circuitName) + Nothing + else do + res <- + action `catchError` \err -> do + liftIO $ atomically $ do + (st, fails) <- readTVar circuitStateVar + let newFails = fails + 1 + if newFails >= failureThreshold circuitConfig + then writeTVar circuitStateVar (CircuitOpen now, newFails) + else writeTVar circuitStateVar (st, newFails) + throwError err + + -- On success, reset circuit to closed and reset failure count + liftIO $ atomically $ writeTVar circuitStateVar (CircuitClosed, 0) + pure res diff --git a/src/Langchain/Resilience/Retry.hs b/src/Langchain/Resilience/Retry.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Resilience/Retry.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.Resilience.Retry +Description : Retry policies with exponential backoff and token-bucket rate limiting +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Resilience combinators for network calls and LLM provider invocations. +-} +module Langchain.Resilience.Retry + ( RetryPolicy (..) + , defaultRetryPolicy + , withRetry + , RateLimiter (..) + , newRateLimiter + , withRateLimit + ) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.STM +import Control.Monad (when) +import Control.Monad.Except (MonadError, catchError, throwError) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Time.Clock +import System.Random (randomRIO) + +import Langchain.Error (LangchainError) + +-- | Exponential backoff retry policy +data RetryPolicy = RetryPolicy + { maxRetries :: !Int + , baseDelayMicros :: !Int + , maxDelayMicros :: !Int + , useJitter :: !Bool + } + deriving (Show, Eq) + +-- | Default retry policy (3 retries, base 50ms, max 2s, with jitter) +defaultRetryPolicy :: RetryPolicy +defaultRetryPolicy = + RetryPolicy + { maxRetries = 3 + , baseDelayMicros = 50000 + , maxDelayMicros = 2000000 + , useJitter = True + } + +-- | Execute an action with retry according to RetryPolicy on LangchainError +withRetry :: + (MonadIO m, MonadError LangchainError m) => + RetryPolicy -> + m a -> + m a +withRetry policy action = go (maxRetries policy) (baseDelayMicros policy) + where + go retriesLeft currentDelay = + action `catchError` \err -> + if retriesLeft <= 0 + then throwError err + else do + delayWithJitter <- + if useJitter policy + then liftIO $ randomRIO (currentDelay `div` 2, currentDelay) + else pure currentDelay + liftIO $ threadDelay delayWithJitter + let nextDelay = min (maxDelayMicros policy) (currentDelay * 2) + go (retriesLeft - 1) nextDelay + +-- | Token bucket rate limiter backed by STM TVars +data RateLimiter = RateLimiter + { bucketCapacity :: !Double + , refillRatePerSec :: !Double + , tokensVar :: !(TVar Double) + , lastRefillVar :: !(TVar UTCTime) + } + +-- | Construct a new Token Bucket RateLimiter (e.g. capacity = 10 tokens, refill = 5 tokens/sec) +newRateLimiter :: MonadIO m => Double -> Double -> m RateLimiter +newRateLimiter cap rate = liftIO $ do + now <- getCurrentTime + tVar <- newTVarIO cap + rVar <- newTVarIO now + pure $ RateLimiter cap rate tVar rVar + +-- | Execute an action subject to token-bucket rate limiting (blocks if bucket empty) +withRateLimit :: (MonadIO m) => RateLimiter -> m a -> m a +withRateLimit RateLimiter {..} action = do + liftIO $ do + waitForToken + action + where + waitForToken = do + now <- getCurrentTime + waitNeeded <- atomically $ do + lastTime <- readTVar lastRefillVar + tokens <- readTVar tokensVar + let elapsedSecs = realToFrac (diffUTCTime now lastTime) :: Double + refilledTokens = min bucketCapacity (tokens + elapsedSecs * refillRatePerSec) + if refilledTokens >= 1.0 + then do + writeTVar tokensVar (refilledTokens - 1.0) + writeTVar lastRefillVar now + pure (0 :: Int) + else do + let deficit = 1.0 - refilledTokens + sleepSecs = deficit / refillRatePerSec + pure (ceiling (sleepSecs * 1000000) :: Int) + when (waitNeeded > 0) $ do + threadDelay waitNeeded + waitForToken diff --git a/src/Langchain/Retriever.hs b/src/Langchain/Retriever.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Retriever.hs @@ -0,0 +1,20 @@ +{- | +Module : Langchain.Retriever +Description : Document retrieval mechanisms +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Retrieval mechanisms including vector store retrieval, Okapi BM25 sparse retrieval, +and Reciprocal Rank Fusion hybrid retrieval. +-} +module Langchain.Retriever + ( module Langchain.Retriever.Core + , module Langchain.Retriever.BM25 + , module Langchain.Retriever.Hybrid + ) where + +import Langchain.Retriever.BM25 +import Langchain.Retriever.Core +import Langchain.Retriever.Hybrid diff --git a/src/Langchain/Retriever/BM25.hs b/src/Langchain/Retriever/BM25.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Retriever/BM25.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module : Langchain.Retriever.BM25 +Description : Okapi BM25 Sparse Inverted Index Retriever +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Pure Haskell implementation of the Okapi BM25 ranking algorithm for sparse keyword retrieval. +Supports document addition, customized k1 and b parameters, and fast inverted index scoring. +-} +module Langchain.Retriever.BM25 + ( BM25Index (..) + , newBM25Index + , newBM25IndexWithParams + , addDocumentsBM25 + , bm25Search + , bm25SearchWithScores + , tokenize + ) where + +import Langchain.Runnable (Runnable (..)) + +import Data.Char (isAlphaNum) +#if MIN_VERSION_base(4,20,0) +import Data.List (sortBy) +#else +import Data.List (foldl', sortBy) +#endif +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Ord (Down (..), comparing) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import GHC.Generics (Generic) + +import Langchain.DocumentLoader.Core (Document (..)) +import Langchain.Retriever.Core (Retriever (..)) + +-- | BM25 Index containing documents, lengths, and inverted index +data BM25Index = BM25Index + { bm25Docs :: ![Document] + , bm25DocLens :: !(Map Int Int) + , bm25AvgDocLen :: !Double + , bm25InvertedIndex :: !(Map Text (Map Int Int)) + , bm25K1 :: !Double + , bm25B :: !Double + } + deriving (Show, Eq, Generic) + +instance Retriever BM25Index where + getRelevantDocuments index query = pure $ bm25Search index query 5 + +-- | Tokenize text into lowercased alphanumeric terms +tokenize :: Text -> [Text] +tokenize = filter (not . T.null) . map (T.filter isAlphaNum . T.toLower) . T.words + +-- | Construct a BM25 index with default parameters (k1 = 1.5, b = 0.75) +newBM25Index :: [Document] -> BM25Index +newBM25Index = newBM25IndexWithParams 1.5 0.75 + +-- | Construct a BM25 index with customized k1 and b parameters +newBM25IndexWithParams :: Double -> Double -> [Document] -> BM25Index +newBM25IndexWithParams k1 b docs = + let indexedDocs = zip [0 ..] docs + docLensList = [(i, length (tokenize (TL.toStrict (pageContent d)))) | (i, d) <- indexedDocs] + docLens = Map.fromList docLensList + totalTokens = sum (map snd docLensList) + nDocs = length docs + avgLen = if nDocs > 0 then fromIntegral totalTokens / fromIntegral nDocs else 0.0 + + -- Build inverted index: term -> docIndex -> termFrequency + invIndex = foldl' addDocToInvertedIndex Map.empty indexedDocs + in BM25Index + { bm25Docs = docs + , bm25DocLens = docLens + , bm25AvgDocLen = avgLen + , bm25InvertedIndex = invIndex + , bm25K1 = k1 + , bm25B = b + } + where + addDocToInvertedIndex acc (docIdx, doc) = + let tokens = tokenize (TL.toStrict (pageContent doc)) + tfs = foldl' (\m t -> Map.insertWith (+) t 1 m) Map.empty tokens + in Map.foldlWithKey' + (\accM t count -> Map.insertWith Map.union t (Map.singleton docIdx count) accM) + acc + tfs + +-- | Add new documents to an existing BM25 index +addDocumentsBM25 :: [Document] -> BM25Index -> BM25Index +addDocumentsBM25 newDocs BM25Index {..} = + newBM25IndexWithParams bm25K1 bm25B (bm25Docs ++ newDocs) + +-- | Perform BM25 search returning top-k documents sorted by score +bm25Search :: BM25Index -> Text -> Int -> [Document] +bm25Search index query k = map fst (bm25SearchWithScores index query k) + +-- | Perform BM25 search returning top-k documents with their relevance scores +bm25SearchWithScores :: BM25Index -> Text -> Int -> [(Document, Double)] +bm25SearchWithScores BM25Index {..} query k + | null bm25Docs || null queryTokens = [] + | otherwise = + let nTotalDocs = fromIntegral (length bm25Docs) + -- Accumulate BM25 score per document + scores = foldl' (scoreTerm nTotalDocs) (Map.empty :: Map Int Double) queryTokens + indexedDocs = zip [0 ..] bm25Docs + scoredList = + [ (doc, score) + | (idx, doc) <- indexedDocs + , let score = Map.findWithDefault 0.0 idx scores + , score > 0.0 + ] + sorted = sortBy (comparing (Down . snd)) scoredList + in take k sorted + where + queryTokens = tokenize query + + scoreTerm nTotalDocs accScores term = + case Map.lookup term bm25InvertedIndex of + Nothing -> accScores + Just postingMap -> + let nDocWithTerm = fromIntegral (Map.size postingMap) + -- Okapi BM25 IDF: ln(1 + (N - n + 0.5) / (n + 0.5)) + idf = log (1.0 + (nTotalDocs - nDocWithTerm + 0.5) / (nDocWithTerm + 0.5)) + in Map.foldlWithKey' (updateDocScore idf) accScores postingMap + + updateDocScore idf acc docIdx tf = + let docLen = fromIntegral (Map.findWithDefault 1 docIdx bm25DocLens) + normLen = if bm25AvgDocLen > 0 then docLen / bm25AvgDocLen else 1.0 + tfD = fromIntegral tf + -- Okapi BM25 TF component + tfWeight = (tfD * (bm25K1 + 1.0)) / (tfD + bm25K1 * (1.0 - bm25B + bm25B * normLen)) + scoreDelta = idf * tfWeight + in Map.insertWith (+) docIdx scoreDelta acc + +-- | t'BM25Index' implements 'Runnable' mapping a search query 'Text' to '[Document]' results. +instance Monad m => Runnable BM25Index m where + type RunnableInput BM25Index = Text + type RunnableOutput BM25Index = [Document] + invoke idx query = pure $ Right (bm25Search idx query 5) diff --git a/src/Langchain/Retriever/Core.hs b/src/Langchain/Retriever/Core.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Retriever/Core.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE FlexibleContexts #-} + +{- | +Module : Langchain.Retriever.Core +Description : Retrieval mechanism implementation for LangChain Haskell +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Effect-polymorphic document retrieval abstraction. +-} +module Langchain.Retriever.Core + ( Retriever (..) + , VectorStoreRetriever (..) + , retrieveWithCallbacks + , runRetriever + ) where + +import Control.Monad.Except (MonadError, runExceptT) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Text (Text) +import qualified Data.Text.Lazy as TL +import Data.Time.Clock (diffUTCTime, getCurrentTime) + +import Langchain.Callback.Manager (CallbackEvent (..), CallbackManager, dispatchEvent) +import Langchain.DocumentLoader.Core (Document (..)) +import Langchain.Error (LangchainError) +import Langchain.Runnable (RunnableTree, runLambda) +import Langchain.VectorStore.Core (VectorStore, similaritySearch) + +-- | Effect-polymorphic Retriever typeclass +class Retriever a where + getRelevantDocuments :: + (MonadIO m, MonadError LangchainError m) => + a -> + Text -> + m [Document] + +-- | Vector store-backed retriever +newtype VectorStore a => VectorStoreRetriever a = VectorStoreRetriever {vs :: a} + deriving (Eq, Show) + +instance VectorStore a => Retriever (VectorStoreRetriever a) where + getRelevantDocuments (VectorStoreRetriever v) query = similaritySearch v query 5 + +-- | Retrieve documents with lifecycle callbacks dispatched to CallbackManager +retrieveWithCallbacks :: + (Retriever a, MonadIO m, MonadError LangchainError m) => + CallbackManager -> + Text -> + a -> + Text -> + m [Document] +retrieveWithCallbacks mgr name ret query = do + start <- liftIO getCurrentTime + dispatchEvent mgr (OnRetrieverStart name query start) + docs <- getRelevantDocuments ret query + end <- liftIO getCurrentTime + let durMicros = round (diffUTCTime end start * 1000000) + dispatchEvent mgr (OnRetrieverEnd name (map (TL.toStrict . pageContent) docs) durMicros end) + pure docs + +-- | Lift any 'Retriever' into a 'Text' -> '[Document]' pipeline step in a 'RunnableTree'. +runRetriever :: (Retriever a, MonadIO m) => a -> RunnableTree m Text [Document] +runRetriever ret = runLambda $ \query -> runExceptT (getRelevantDocuments ret query) diff --git a/src/Langchain/Retriever/Hybrid.hs b/src/Langchain/Retriever/Hybrid.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Retriever/Hybrid.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module : Langchain.Retriever.Hybrid +Description : Hybrid Dense + Sparse Retriever with Reciprocal Rank Fusion (RRF) +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Combines sparse keyword search (BM25) and dense semantic vector search using +Reciprocal Rank Fusion (RRF) scoring: RRF(d) = sum_i ( weight_i / (k + rank_i(d)) ). +-} +module Langchain.Retriever.Hybrid + ( HybridRetriever (..) + , newHybridRetriever + , newHybridRetrieverWithWeights + , searchHybrid + , searchHybridWithScores + , reciprocalRankFusion + ) where + +import Control.Monad.Except (runExceptT) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Langchain.Runnable (Runnable (..)) +#if MIN_VERSION_base(4,20,0) +import Data.List (sortBy) +#else +import Data.List (foldl', sortBy) +#endif +import qualified Data.Map.Strict as Map +import Data.Ord (Down (..), comparing) +import Data.Text (Text) + +import Langchain.DocumentLoader.Core (Document (..)) +import Langchain.Retriever.BM25 (BM25Index, bm25Search) +import Langchain.Retriever.Core (Retriever (..)) + +-- | Configuration and handles for Hybrid Retrieval +data HybridRetriever = HybridRetriever + { hybridBM25 :: !BM25Index + , hybridVectorSearch :: !(Text -> Int -> IO [Document]) + , hybridRrfK :: !Double + , hybridDenseWeight :: !Double + , hybridSparseWeight :: !Double + } + +instance Show HybridRetriever where + show HybridRetriever {..} = + "HybridRetriever { hybridRrfK = " + ++ show hybridRrfK + ++ ", hybridDenseWeight = " + ++ show hybridDenseWeight + ++ ", hybridSparseWeight = " + ++ show hybridSparseWeight + ++ " }" + +instance Retriever HybridRetriever where + getRelevantDocuments hr query = searchHybrid hr query 5 + +-- | Construct a default Hybrid Retriever (rrfK = 60.0, equal weights = 1.0) +newHybridRetriever :: + BM25Index -> + (Text -> Int -> IO [Document]) -> + HybridRetriever +newHybridRetriever bm25 vecSearch = + newHybridRetrieverWithWeights bm25 vecSearch 60.0 1.0 1.0 + +-- | Construct a Hybrid Retriever with custom RRF smoothing and weights +newHybridRetrieverWithWeights :: + BM25Index -> + (Text -> Int -> IO [Document]) -> + Double -> + Double -> + Double -> + HybridRetriever +newHybridRetrieverWithWeights bm25 vecSearch rrfK denseW sparseW = + HybridRetriever + { hybridBM25 = bm25 + , hybridVectorSearch = vecSearch + , hybridRrfK = rrfK + , hybridDenseWeight = denseW + , hybridSparseWeight = sparseW + } + +-- | Compute Reciprocal Rank Fusion score for documents across ranked lists +reciprocalRankFusion :: + Double -> + [([Document], Double)] -> -- List of (ranked documents, weight) + [(Document, Double)] +reciprocalRankFusion rrfK rankedLists = + let scoreMap = foldl' processList Map.empty rankedLists + docLookup = foldl' buildLookup Map.empty [d | (docs, _) <- rankedLists, d <- docs] + scoredDocs = + [ (doc, score) + | (contentKey, score) <- Map.toList scoreMap + , Just doc <- [Map.lookup contentKey docLookup] + ] + in sortBy (comparing (Down . snd)) scoredDocs + where + processList accMap (docs, weight) = + let indexed = zip [1 ..] docs + in foldl' (updateScore weight) accMap indexed + + updateScore weight acc (rank, doc) = + let key = pageContent doc + delta = weight / (rrfK + rank) + in Map.insertWith (+) key delta acc + + buildLookup acc doc = Map.insert (pageContent doc) doc acc + +-- | Execute hybrid search returning top-k documents +searchHybrid :: + (MonadIO m) => + HybridRetriever -> + Text -> + Int -> + m [Document] +searchHybrid hr query k = map fst <$> searchHybridWithScores hr query k + +-- | Execute hybrid search returning top-k documents with RRF scores +searchHybridWithScores :: + (MonadIO m) => + HybridRetriever -> + Text -> + Int -> + m [(Document, Double)] +searchHybridWithScores HybridRetriever {..} query k = do + -- 1. Run sparse BM25 search (fetch 2 * k candidates) + let sparseDocs = bm25Search hybridBM25 query (k * 2) + + -- 2. Run dense vector search (fetch 2 * k candidates) + denseDocs <- liftIO $ hybridVectorSearch query (k * 2) + + -- 3. Fuse rankings via RRF + let fused = + reciprocalRankFusion + hybridRrfK + [ (denseDocs, hybridDenseWeight) + , (sparseDocs, hybridSparseWeight) + ] + + pure $ take k fused + +-- | t'HybridRetriever' implements 'Runnable' mapping search query 'Text' to fused '[Document]' results. +instance MonadIO m => Runnable HybridRetriever m where + type RunnableInput HybridRetriever = Text + type RunnableOutput HybridRetriever = [Document] + invoke hr query = runExceptT (searchHybrid hr query 5) diff --git a/src/Langchain/Runnable.hs b/src/Langchain/Runnable.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Runnable.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | +Module : Langchain.Runnable +Description : Pure pipeline GADT (RunnableTree) and algebraic composition +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Pure, AST-based pipeline representation ('RunnableTree') where building pipelines performs +NO side effects. Execution is strictly deferred to 'interpret'. +Provides full configuration binding for 'ChatModel' instances. +-} +module Langchain.Runnable + ( Runnable (..) + , RunnableTree (..) + , (|>>) + , (&>&) + , interpret + , runLambda + , runPrim + , runPure + , runPassthrough + , runIdent + , runBranch + , runFallback + , runChat + , runChatWithConfig + , runModel + , runModelWithConfig + , runConfiguredModel + , ModelRunnable (..) + , modelRunnable + , modelRunnableWithConfig + , bindConfig + , TextModelRunnable (..) + , textModelRunnable + , textModelRunnableWithConfig + , bindTextConfig + , ConfiguredModelRunnable (..) + ) where + +import Control.Concurrent.Async (concurrently) +import Control.Monad.Except (ExceptT, MonadError, catchError, runExceptT, throwError) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (Value) +import Data.Kind (Type) +import Data.Text (Text) + +import Langchain.Error (LangchainError) +import Langchain.Model (ChatModel, ModelConfig, extractMessageText, userMessage) +import qualified Langchain.Model as M (invoke) +import Langchain.Model.Types (Message) +import Langchain.Tool (Tool (..)) + +-- | Fundamental Runnable interface for components wrapped in 'Prim'. +class Runnable r m where + type RunnableInput r :: Type + type RunnableOutput r :: Type + invoke :: r -> RunnableInput r -> m (Either LangchainError (RunnableOutput r)) + +-- | Any Tool can be executed as a primitive Runnable taking JSON 'Value' to 'Text'. +instance Runnable (Tool m) m where + type RunnableInput (Tool m) = Value + type RunnableOutput (Tool m) = Text + invoke = toolExecute + +-- --------------------------------------------------------------------------- +-- Model Runnables with Configuration Support +-- --------------------------------------------------------------------------- + +-- | Wrapper to treat any 'ChatModel' as a Runnable over '[Message]' -> 'Message' with optional bound configuration. +data ModelRunnable c = ModelRunnable + { modelRunnableModel :: !c + , modelRunnableConfig :: !(Maybe (ModelConfig c)) + } + +deriving instance (Show c, Show (ModelConfig c)) => Show (ModelRunnable c) +deriving instance (Eq c, Eq (ModelConfig c)) => Eq (ModelRunnable c) + +-- | Construct a ModelRunnable without pre-set configuration. +modelRunnable :: c -> ModelRunnable c +modelRunnable c = ModelRunnable c Nothing + +-- | Construct a ModelRunnable with pre-bound model configuration. +modelRunnableWithConfig :: c -> ModelConfig c -> ModelRunnable c +modelRunnableWithConfig c cfg = ModelRunnable c (Just cfg) + +-- | Bind or replace the configuration on a ModelRunnable (equivalent to LangChain's model.bind). +bindConfig :: ModelConfig c -> ModelRunnable c -> ModelRunnable c +bindConfig cfg (ModelRunnable c _) = ModelRunnable c (Just cfg) + +instance (ChatModel c, MonadIO m) => Runnable (ModelRunnable c) m where + type RunnableInput (ModelRunnable c) = [Message] + type RunnableOutput (ModelRunnable c) = Message + invoke (ModelRunnable c mCfg) msgs = runExceptT (M.invoke c msgs mCfg) + +-- | Wrapper to treat any 'ChatModel' as a simple 'Text' -> 'Text' Runnable with optional bound configuration. +data TextModelRunnable c = TextModelRunnable + { textModelRunnableModel :: !c + , textModelRunnableConfig :: !(Maybe (ModelConfig c)) + } + +deriving instance (Show c, Show (ModelConfig c)) => Show (TextModelRunnable c) +deriving instance (Eq c, Eq (ModelConfig c)) => Eq (TextModelRunnable c) + +-- | Construct a TextModelRunnable without pre-set configuration. +textModelRunnable :: c -> TextModelRunnable c +textModelRunnable c = TextModelRunnable c Nothing + +-- | Construct a TextModelRunnable with pre-bound model configuration. +textModelRunnableWithConfig :: c -> ModelConfig c -> TextModelRunnable c +textModelRunnableWithConfig c cfg = TextModelRunnable c (Just cfg) + +-- | Bind or replace the configuration on a TextModelRunnable. +bindTextConfig :: ModelConfig c -> TextModelRunnable c -> TextModelRunnable c +bindTextConfig cfg (TextModelRunnable c _) = TextModelRunnable c (Just cfg) + +instance (ChatModel c, MonadIO m) => Runnable (TextModelRunnable c) m where + type RunnableInput (TextModelRunnable c) = Text + type RunnableOutput (TextModelRunnable c) = Text + invoke (TextModelRunnable c mCfg) prompt = do + res <- runExceptT $ M.invoke c [userMessage prompt] mCfg + pure (extractMessageText <$> res) + +-- | Dynamic model runnable allowing model configuration to be passed per-request. +newtype ConfiguredModelRunnable c = ConfiguredModelRunnable c + deriving (Eq, Show) + +instance (ChatModel c, MonadIO m) => Runnable (ConfiguredModelRunnable c) m where + type RunnableInput (ConfiguredModelRunnable c) = ([Message], Maybe (ModelConfig c)) + type RunnableOutput (ConfiguredModelRunnable c) = Message + invoke (ConfiguredModelRunnable c) (msgs, mCfg) = runExceptT (M.invoke c msgs mCfg) + +-- --------------------------------------------------------------------------- +-- RunnableTree Pipeline AST +-- --------------------------------------------------------------------------- + +{- | Pure GADT representing a composable pipeline AST. +@i@ = input type, @o@ = output type, @m@ = monad context. +-} +data RunnableTree m i o where + -- | Identity: passes input through unchanged + Id :: RunnableTree m a a + -- | Lift a component implementing Runnable into the tree + Prim :: + (Runnable r m, RunnableInput r ~ i, RunnableOutput r ~ o) => + r -> + RunnableTree m i o + -- | Lift a monadic function into the tree + Lambda :: (i -> m (Either LangchainError o)) -> RunnableTree m i o + -- | Sequential composition AST node + Seq :: RunnableTree m i mid -> RunnableTree m mid o -> RunnableTree m i o + -- | Parallel composition AST node + Par :: + RunnableTree (ExceptT LangchainError IO) i o1 -> + RunnableTree (ExceptT LangchainError IO) i o2 -> + RunnableTree (ExceptT LangchainError IO) i (o1, o2) + -- | Conditional branching AST node + Branch :: + (i -> m Bool) -> + -- | True branch + RunnableTree m i o -> + -- | False branch + RunnableTree m i o -> + RunnableTree m i o + -- | Fallback node: if primary fails, executes fallback + Fallback :: RunnableTree m i o -> RunnableTree m i o -> RunnableTree m i o + +-- | Sequential composition operator — PURE AST builder. +(|>>) :: RunnableTree m a b -> RunnableTree m b c -> RunnableTree m a c +(|>>) = Seq + +infixl 1 |>> + +-- | Parallel composition operator — PURE AST builder. +(&>&) :: + RunnableTree (ExceptT LangchainError IO) a b -> + RunnableTree (ExceptT LangchainError IO) a c -> + RunnableTree (ExceptT LangchainError IO) a (b, c) +(&>&) = Par + +infixl 2 &>& + +-- | Helper to create a lambda runnable node. +runLambda :: (i -> m (Either LangchainError o)) -> RunnableTree m i o +runLambda = Lambda + +-- | Helper to create a primitive runnable node. +runPrim :: + (Runnable r m, RunnableInput r ~ i, RunnableOutput r ~ o) => + r -> + RunnableTree m i o +runPrim = Prim + +-- | Helper to convert Either to MonadError +liftEither :: MonadError LangchainError m => Either LangchainError a -> m a +liftEither (Left err) = throwError err +liftEither (Right x) = pure x + +-- | Sole execution engine for 'RunnableTree' AST pipelines. +interpret :: + (MonadIO m, MonadError LangchainError m) => + RunnableTree m i o -> + i -> + m o +interpret Id input = pure input +interpret (Prim r) input = invoke r input >>= liftEither +interpret (Lambda f) input = f input >>= liftEither +interpret (Seq t1 t2) input = interpret t1 input >>= interpret t2 +interpret (Par t1 t2) input = do + (r1, r2) <- + liftIO $ + concurrently + (runExceptT $ interpret t1 input) + (runExceptT $ interpret t2 input) + o1 <- liftEither r1 + o2 <- liftEither r2 + pure (o1, o2) +interpret (Branch cond tTrue tFalse) input = do + b <- cond input + if b then interpret tTrue input else interpret tFalse input +interpret (Fallback t1 t2) input = + catchError (interpret t1 input) (\_ -> interpret t2 input) + +-- | Lift a pure function into a 'RunnableTree' node. +runPure :: Monad m => (i -> o) -> RunnableTree m i o +runPure f = runLambda (pure . Right . f) + +-- | Identity node in a 'RunnableTree' (passes input through unchanged, like LangChain's @RunnablePassthrough@). +runPassthrough :: RunnableTree m a a +runPassthrough = Id + +-- | Alias for 'runPassthrough'. +runIdent :: RunnableTree m a a +runIdent = Id + +-- | Construct a conditional branch AST node. +runBranch :: (i -> m Bool) -> RunnableTree m i o -> RunnableTree m i o -> RunnableTree m i o +runBranch = Branch + +-- | Construct a self-healing fallback AST node (tries first, catches errors and runs second). +runFallback :: RunnableTree m i o -> RunnableTree m i o -> RunnableTree m i o +runFallback = Fallback + +-- | Lift any 'ChatModel' into a simple 'Text' -> 'Text' pipeline step (without configuration). +runChat :: (ChatModel c, MonadIO m) => c -> RunnableTree m Text Text +runChat c = runPrim (TextModelRunnable c Nothing) + +-- | Lift any 'ChatModel' into a simple 'Text' -> 'Text' pipeline step with bound model configuration. +runChatWithConfig :: (ChatModel c, MonadIO m) => c -> ModelConfig c -> RunnableTree m Text Text +runChatWithConfig c cfg = runPrim (TextModelRunnable c (Just cfg)) + +-- | Lift any 'ChatModel' into a structured '[Message]' -> 'Message' pipeline step (without configuration). +runModel :: (ChatModel c, MonadIO m) => c -> RunnableTree m [Message] Message +runModel c = runPrim (ModelRunnable c Nothing) + +-- | Lift any 'ChatModel' into a structured '[Message]' -> 'Message' pipeline step with bound model configuration. +runModelWithConfig :: + (ChatModel c, MonadIO m) => c -> ModelConfig c -> RunnableTree m [Message] Message +runModelWithConfig c cfg = runPrim (ModelRunnable c (Just cfg)) + +-- | Lift any 'ChatModel' into a pipeline step taking dynamic messages and configuration per request. +runConfiguredModel :: + (ChatModel c, MonadIO m) => c -> RunnableTree m ([Message], Maybe (ModelConfig c)) Message +runConfiguredModel c = runPrim (ConfiguredModelRunnable c) diff --git a/src/Langchain/Stream.hs b/src/Langchain/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Stream.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# OPTIONS_GHC -Wno-partial-fields #-} + +{- | +Module : Langchain.Stream +Description : Standardized StreamEvent protocol and utilities +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Structured streaming event protocol for tracking LLM, tool, chain, and graph lifecycle events. +-} +module Langchain.Stream + ( TokenUsage (..) + , StreamEvent (..) + , StreamM + , EventStream + , ChatStream + , StreamCallback + , StreamSource + , callbackSource + , collectEvents + , printEvents + ) where + +import Control.Concurrent.Async (async, cancel) +import Control.Concurrent.STM + ( atomically + , newEmptyTMVarIO + , newTBQueueIO + , orElse + , putTMVar + , readTBQueue + , readTMVar + , writeTBQueue + ) +import Control.Exception (finally) +import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (ResourceT, runResourceT) +import Data.Aeson (FromJSON, ToJSON, Value) +import Data.Conduit (ConduitT, bracketP, runConduit, yield, (.|)) +import qualified Data.Conduit.List as CL +import Data.Text (Text) +import GHC.Generics (Generic) +import Langchain.Error (LangchainError) +import Langchain.Model.Types (Message, ToolCall) + +-- | Token usage accounting for LLM execution. +data TokenUsage = TokenUsage + { promptTokens :: Int + , completionTokens :: Int + , totalTokens :: Int + } + deriving (Eq, Show, Generic, ToJSON, FromJSON) + +{- | All streaming events emitted across the framework execution lifecycle. +Every event carries a 'runId' for correlation. +-} +data StreamEvent + = -- | LLM lifecycle start + LLMStart + { runId :: Text + , modelName :: Text + , inputMessages :: [Message] + } + | -- | LLM incremental streaming chunk + LLMChunk + { runId :: Text + , chunkText :: Text + , toolCallDelta :: Maybe ToolCall + } + | -- | LLM lifecycle completion + LLMEnd + { runId :: Text + , finalMessage :: Message + , tokenUsage :: Maybe TokenUsage + } + | -- | Tool execution start + ToolStart + { runId :: Text + , toolName :: Text + , toolInput :: Value + } + | -- | Tool execution completion + ToolEnd + { runId :: Text + , toolName :: Text + , toolOutput :: Value + } + | -- | Tool execution failure + ToolErrorEvent + { runId :: Text + , toolName :: Text + , toolErrorPayload :: LangchainError + } + | -- | Chain execution start + ChainStart + { runId :: Text + , chainName :: Text + , chainInput :: Value + } + | -- | Chain execution completion + ChainEnd + { runId :: Text + , chainName :: Text + , chainOutput :: Value + } + | -- | Graph node execution start + NodeStart + { runId :: Text + , nodeId :: Text + , nodeState :: Value + } + | -- | Graph node execution completion + NodeEnd + { runId :: Text + , nodeId :: Text + , nodeState :: Value + } + deriving (Eq, Show, Generic, ToJSON, FromJSON) + +-- | Canonical event stream type using Conduit. +type EventStream m = ConduitT () StreamEvent m () + +-- | Effects used by resource-safe chat model streams. +type StreamM = ExceptT LangchainError (ResourceT IO) + +-- | A resource-safe stream of chat model events. +type ChatStream = EventStream StreamM + +-- | A callback function that produces values of type @a@. +type StreamCallback a = (a -> IO ()) -> IO () + +-- | A Conduit source that produces values of type @a@ in the 'StreamM' monad. +type StreamSource a = ConduitT () a StreamM () + +-- | Convert a callback-based streaming function into a Conduit source. +callbackSource :: StreamCallback a -> StreamSource a +callbackSource produce = bracketP start (cancel . third) consume + where + start = do + queue <- newTBQueueIO 64 + finished <- newEmptyTMVarIO + worker <- + async $ produce (atomically . writeTBQueue queue) `finally` atomically (putTMVar finished ()) + pure (queue, finished, worker) + + consume (queue, finished, _worker) = loop + where + loop = do + let waitForFinished = Nothing <$ readTMVar finished + readEvent = Just <$> readTBQueue queue + next <- liftIO . atomically $ readEvent `orElse` waitForFinished + case next of + Just item -> yield item >> loop + Nothing -> pure () + + third (_, _, worker) = worker + +-- | Collect all emitted events from a stream into a list. +collectEvents :: Monad m => EventStream m -> m [StreamEvent] +collectEvents streamSrc = runConduit (streamSrc .| CL.consume) + +-- | Debug helper: print all stream events to stdout. +printEvents :: EventStream (ExceptT LangchainError (ResourceT IO)) -> IO (Either LangchainError ()) +printEvents streamSrc = runResourceT $ runExceptT $ runConduit (streamSrc .| CL.mapM_ (liftIO . print)) diff --git a/src/Langchain/TextSplitter/Character.hs b/src/Langchain/TextSplitter/Character.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/TextSplitter/Character.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.TextSplitter.Character +Description : Character-based text splitting for LLM processing [[10]] +Copyright : (c) 2025 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Character-based text splitting implementation following LangChain's text splitter concepts. +Splits text into chunks based on separators and maximum chunk sizes, useful for processing +large documents with LLMs. + +For more information on text splitting concepts, see the Langchain documentation: +[Langchain TextSplitter](https://python.langchain.com/docs/concepts/text_splitters/). + +Example usage: + +@ +-- Split text using default settings (100 char chunks, double newline separator) +splitText defaultCharacterSplitterOps "Long document text..." + +-- Custom configuration for 500-char chunks with paragraph splitting +customSplit = splitText (CharacterSplitterOps 500 "\n\\s*\n") +@ +-} +module Langchain.TextSplitter.Character + ( -- * Configuration + CharacterSplitterOps (..) + , defaultCharacterSplitterOps + + -- * Splitting Function + , splitText + ) where + +import Data.Int (Int64) +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T + +{- | Configuration for character-based text splitting +Contains: + +- 'chunkSize' : Maximum characters per chunk +- 'separator' : Pattern to split text before chunking + +Default values follow LangChain's recommended settings for LLM input preparation. +-} +data CharacterSplitterOps = CharacterSplitterOps + { chunkSize :: Int64 + , separator :: Text + } + deriving (Show, Eq) + +{- | Default splitter configuration + +- 100 character chunks +- Splits on double newlines ("\n\n") + +>>> defaultCharacterSplitterOps +CharacterSplitterOps {chunkSize = 100, separator = "\n\n"} +-} +defaultCharacterSplitterOps :: CharacterSplitterOps +defaultCharacterSplitterOps = + CharacterSplitterOps + { chunkSize = 100 + , separator = "\n\n" + } + +{- | Split text into chunks following LangChain's splitting strategy: + - +1. Split by separator first +2. Chunk each segment into specified size +3. Preserve semantic boundaries where possible + +Examples: +>>> splitText defaultCharacterSplitterOps "" +[] + +>>> splitText defaultCharacterSplitterOps "Short text" +["Short text"] + +>>> splitText defaultCharacterSplitterOps "Part1\n\nPart2\n\nPart3" +["Part1", "Part2", "Part3"] + +>>> splitText (CharacterSplitterOps 20 "\n\n") "Very long text exceeding chunk size..." +["Very long text ex", "ceeding chunk size..."] +-} +splitText :: CharacterSplitterOps -> Text -> [Text] +splitText CharacterSplitterOps {..} txt = + mconcat $ + map + (T.chunksOf chunkSize . T.strip) + (if T.null separator then [txt] else T.splitOn separator txt) + +{- $examples +Test case patterns demonstrating key behaviors: + +1. Empty input handling + >>> splitText defaultCharacterSplitterOps "" + [] + +2. Custom separator usage + >>> splitText (CharacterSplitterOps 100 "|") "A|B|C" + ["A", "B", "C"] + +3. Combined splitting and chunking + >>> splitText (CharacterSplitterOps 10 "\n") "1234567890\nABCDEFGHIJ" + ["1234567890", "ABCDEFGHIJ"] +-} diff --git a/src/Langchain/TextSplitter/Code.hs b/src/Langchain/TextSplitter/Code.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/TextSplitter/Code.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Langchain.TextSplitter.Code +Description : Language-aware code text splitter +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Splits programming language source code at top-level declarations, class/function +boundaries, or language-specific constructs. +-} +module Langchain.TextSplitter.Code + ( Language (..) + , CodeSplitterOps (..) + , defaultCodeSplitterOps + , languageSeparators + , splitCode + ) where + +import Data.Int (Int64) +import Data.Text.Lazy (Text) + +import Langchain.TextSplitter.RecursiveCharacter + ( RecursiveCharacterSplitterOps (..) + , splitTextRecursive + ) + +-- | Supported programming languages for code splitting +data Language + = Haskell + | Python + | JavaScript + | TypeScript + | Rust + | Go + | Java + | Cpp + | CSharp + | MarkdownCode + deriving (Show, Eq, Enum, Bounded) + +-- | Configuration options for code splitting +data CodeSplitterOps = CodeSplitterOps + { codeLanguage :: Language + , codeChunkSize :: Int64 + , codeChunkOverlap :: Int64 + } + deriving (Show, Eq) + +-- | Return language-specific separator hierarchy +languageSeparators :: Language -> [Text] +languageSeparators Haskell = + [ "\nmodule " + , "\ndata " + , "\nnewtype " + , "\ntype " + , "\nclass " + , "\ninstance " + , "\n\n" + , "\n" + , " " + , "" + ] +languageSeparators Python = + [ "\nclass " + , "\ndef " + , "\n\tdef " + , "\n\n" + , "\n" + , " " + , "" + ] +languageSeparators JavaScript = + [ "\nfunction " + , "\nclass " + , "\nexport default " + , "\nexport const " + , "\nconst " + , "\nlet " + , "\nvar " + , "\n\n" + , "\n" + , " " + , "" + ] +languageSeparators TypeScript = languageSeparators JavaScript +languageSeparators Rust = + [ "\nfn " + , "\npub fn " + , "\nstruct " + , "\npub struct " + , "\nenum " + , "\npub enum " + , "\nimpl " + , "\ntrait " + , "\n\n" + , "\n" + , " " + , "" + ] +languageSeparators Go = + [ "\nfunc " + , "\ntype " + , "\n\n" + , "\n" + , " " + , "" + ] +languageSeparators Java = + [ "\npublic class " + , "\nclass " + , "\npublic interface " + , "\ninterface " + , "\npublic enum " + , "\npublic " + , "\nprivate " + , "\nprotected " + , "\n\n" + , "\n" + , " " + , "" + ] +languageSeparators Cpp = + [ "\nclass " + , "\nstruct " + , "\nenum " + , "\ntemplate " + , "\n\n" + , "\n" + , " " + , "" + ] +languageSeparators CSharp = languageSeparators Java +languageSeparators MarkdownCode = + [ "\n# " + , "\n## " + , "\n### " + , "\n#### " + , "\n```" + , "\n\n" + , "\n" + , " " + , "" + ] + +-- | Default code splitter options for a language +defaultCodeSplitterOps :: Language -> CodeSplitterOps +defaultCodeSplitterOps lang = + CodeSplitterOps + { codeLanguage = lang + , codeChunkSize = 1000 + , codeChunkOverlap = 150 + } + +-- | Split code using language-specific syntax separators +splitCode :: CodeSplitterOps -> Text -> [Text] +splitCode ops text = + let seps = languageSeparators (codeLanguage ops) + recOps = + RecursiveCharacterSplitterOps + { chunkSize = codeChunkSize ops + , chunkOverlap = codeChunkOverlap ops + , separators = seps + } + in splitTextRecursive recOps text diff --git a/src/Langchain/TextSplitter/Markdown.hs b/src/Langchain/TextSplitter/Markdown.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/TextSplitter/Markdown.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Langchain.TextSplitter.Markdown +Description : Markdown document header-aware text splitter +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Splits markdown text based on structural headers (# Header 1, ## Header 2, etc.) +and generates chunks with inherited header context. +-} +module Langchain.TextSplitter.Markdown + ( MarkdownSplitterOps (..) + , MarkdownChunk (..) + , defaultMarkdownSplitterOps + , splitMarkdown + , splitMarkdownToChunks + ) where + +import Data.Int (Int64) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T + +import Langchain.TextSplitter.RecursiveCharacter + ( RecursiveCharacterSplitterOps (..) + , defaultRecursiveCharacterSplitterOps + , splitTextRecursive + ) + +-- | Represents a chunk of markdown text with its associated header hierarchy +data MarkdownChunk = MarkdownChunk + { chunkContent :: Text + , chunkHeaders :: Map Text Text + } + deriving (Show, Eq) + +-- | Configuration options for markdown text splitting +data MarkdownSplitterOps = MarkdownSplitterOps + { mdChunkSize :: Int64 + , mdChunkOverlap :: Int64 + , headersToSplitOn :: [(Text, Text)] -- e.g. [("#", "Header 1"), ("##", "Header 2"), ("###", "Header 3")] + } + deriving (Show, Eq) + +-- | Default markdown splitter options +defaultMarkdownSplitterOps :: MarkdownSplitterOps +defaultMarkdownSplitterOps = + MarkdownSplitterOps + { mdChunkSize = 1000 + , mdChunkOverlap = 100 + , headersToSplitOn = + [ ("#", "Header 1") + , ("##", "Header 2") + , ("###", "Header 3") + , ("####", "Header 4") + ] + } + +-- | Split markdown document into MarkdownChunks with header metadata +splitMarkdownToChunks :: MarkdownSplitterOps -> Text -> [MarkdownChunk] +splitMarkdownToChunks _ "" = [] +splitMarkdownToChunks ops text = + let rawLines = T.lines text + sections = groupLinesByHeaders (headersToSplitOn ops) Map.empty rawLines + in concatMap (subSplitSection ops) sections + +-- | Split markdown text into plain Text chunks +splitMarkdown :: MarkdownSplitterOps -> Text -> [Text] +splitMarkdown ops text = map chunkContent (splitMarkdownToChunks ops text) + +-- Group lines into header-annotated sections +groupLinesByHeaders :: [(Text, Text)] -> Map Text Text -> [Text] -> [MarkdownChunk] +groupLinesByHeaders _ _ [] = [] +groupLinesByHeaders headerRules currentHeaders ls = go currentHeaders [] ls + where + go :: Map Text Text -> [Text] -> [Text] -> [MarkdownChunk] + go hdrs acc [] = [MarkdownChunk (T.unlines (reverse acc)) hdrs | not (null acc)] + go hdrs acc (l : rest) = + case matchHeader headerRules l of + Just (hPrefix, hName, hTitle) -> + let currentChunk = [MarkdownChunk (T.unlines (reverse acc)) hdrs | not (null acc)] + -- update headers: clear deeper headers when higher header occurs + newHdrs = updateHeaderMap headerRules hPrefix hName hTitle hdrs + in currentChunk ++ go newHdrs [l] rest + Nothing -> + go hdrs (l : acc) rest + +matchHeader :: [(Text, Text)] -> Text -> Maybe (Text, Text, Text) +matchHeader rules line = + let stripped = T.stripStart line + in findRule rules stripped + where + findRule [] _ = Nothing + findRule ((prefix, name) : rs) s = + let prefixWithSpace = prefix <> " " + in if prefixWithSpace `T.isPrefixOf` s + then Just (prefix, name, T.strip (T.drop (T.length prefixWithSpace) s)) + else findRule rs s + +updateHeaderMap :: [(Text, Text)] -> Text -> Text -> Text -> Map Text Text -> Map Text Text +updateHeaderMap rules prefix name title curMap = + let prefixDepth = T.length prefix + -- keep only headers with depth < prefixDepth + filtered = + Map.filterWithKey + ( \k _ -> case lookupPrefixKey rules k of + Just p -> T.length p < prefixDepth + Nothing -> True + ) + curMap + in Map.insert name title filtered + +lookupPrefixKey :: [(Text, Text)] -> Text -> Maybe Text +lookupPrefixKey [] _ = Nothing +lookupPrefixKey ((p, n) : rest) name + | n == name = Just p + | otherwise = lookupPrefixKey rest name + +subSplitSection :: MarkdownSplitterOps -> MarkdownChunk -> [MarkdownChunk] +subSplitSection ops (MarkdownChunk content hdrs) = + let cSize = mdChunkSize ops + cOverlap = mdChunkOverlap ops + in if T.length content <= cSize + then [MarkdownChunk content hdrs] + else + let subOps = + defaultRecursiveCharacterSplitterOps + { chunkSize = cSize + , chunkOverlap = cOverlap + , separators = ["\n\n", "\n", " ", ""] + } + subPieces = splitTextRecursive subOps content + in [MarkdownChunk piece hdrs | piece <- subPieces] diff --git a/src/Langchain/TextSplitter/RecursiveCharacter.hs b/src/Langchain/TextSplitter/RecursiveCharacter.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/TextSplitter/RecursiveCharacter.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Langchain.TextSplitter.RecursiveCharacter +Description : Hierarchical recursive character text splitting with chunk overlap +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Recursively splits text by trying different separators in order (paragraphs, lines, spaces, characters) +to keep semantically related pieces of text together. +-} +module Langchain.TextSplitter.RecursiveCharacter + ( RecursiveCharacterSplitterOps (..) + , defaultRecursiveCharacterSplitterOps + , splitTextRecursive + ) +where + +import Data.Int (Int64) +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T + +-- | Configuration options for recursive character text splitter +data RecursiveCharacterSplitterOps = RecursiveCharacterSplitterOps + { chunkSize :: Int64 + , chunkOverlap :: Int64 + , separators :: [Text] + } + deriving (Show, Eq) + +-- | Default options: 1000 char chunks, 200 char overlap, standard hierarchy of separators +defaultRecursiveCharacterSplitterOps :: RecursiveCharacterSplitterOps +defaultRecursiveCharacterSplitterOps = + RecursiveCharacterSplitterOps + { chunkSize = 1000 + , chunkOverlap = 200 + , separators = ["\n\n", "\n", " ", ""] + } + +-- | Split text recursively using the specified separators hierarchy +splitTextRecursive :: RecursiveCharacterSplitterOps -> Text -> [Text] +splitTextRecursive _ "" = [] +splitTextRecursive + RecursiveCharacterSplitterOps + { chunkSize = maxSize + , chunkOverlap = maxOverlap + , separators = ss + } + text = splitRecursive ss text + where + splitRecursive :: [Text] -> Text -> [Text] + splitRecursive [] txt = splitByLen txt + splitRecursive ("" : _) txt = splitByLen txt + splitRecursive (sep : seps) txt = mergeWithOverlap sep splitParts + where + splitParts = concatMap (splitRecursive seps) $ filter (not . T.null) $ T.splitOn sep txt + + splitByLen :: Text -> [Text] + splitByLen "" = [] + splitByLen txt = chunk : splitByLen remainder + where + (chunk, remainder) = T.splitAt maxSize txt + + mergeWithOverlap :: Text -> [Text] -> [Text] + mergeWithOverlap _ [] = [] + mergeWithOverlap sep parts = reverse $ go [] 0 [] parts + where + sepLen = T.length sep + toText = T.intercalate sep . reverse + + go :: [Text] -> Int64 -> [Text] -> [Text] -> [Text] + go acc chunkLen chunkParts pss = + case pss of + [] -> acc' + (part : restParts) -> + let partLen = T.length part + chunkLen' = chunkLen + sepBefore chunkParts + partLen + in if chunkLen' <= maxSize + then go acc chunkLen' (part : chunkParts) restParts + else + let (overlapParts, overlapLen) = takeWhileOverlap chunkParts 0 [] + carryLen = overlapLen + sepBefore overlapParts + partLen + in go acc' carryLen (part : reverse overlapParts) restParts + where + acc' = toText chunkParts : acc + + sepBefore ps = if null ps then 0 else sepLen + + takeWhileOverlap [] overlapLen overlapAcc = (overlapAcc, overlapLen) + takeWhileOverlap (overlapPart : restOverlap) overlapLen overlapAcc + | overlapLen' > maxOverlap = (overlapAcc, overlapLen) + | otherwise = takeWhileOverlap restOverlap overlapLen' (overlapPart : overlapAcc) + where + overlapLen' = overlapLen + sepBefore overlapAcc + T.length overlapPart diff --git a/src/Langchain/TextSplitter/Token.hs b/src/Langchain/TextSplitter/Token.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/TextSplitter/Token.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Langchain.TextSplitter.Token +Description : Token-based text splitting with configurable token counter +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Splits text into chunks of specified maximum token counts with optional overlap. +-} +module Langchain.TextSplitter.Token + ( TokenSplitterOps (..) + , defaultTokenSplitterOps + , splitByTokens + , countTokensApprox + ) where + +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T + +-- | Configuration options for token-based text splitting +data TokenSplitterOps = TokenSplitterOps + { maxTokens :: Int + , tokenOverlap :: Int + , tokenCounter :: Text -> Int + } + +instance Show TokenSplitterOps where + show ops = + "TokenSplitterOps { maxTokens = " + ++ show (maxTokens ops) + ++ ", tokenOverlap = " + ++ show (tokenOverlap ops) + ++ " }" + +-- | Approximate token count (roughly 4 characters per token or word-based heuristic) +countTokensApprox :: Text -> Int +countTokensApprox t = + let wCount = length (T.words t) + cCount = fromIntegral (T.length t) `div` 4 + in max wCount cCount + +-- | Default token splitter options (500 tokens, 50 token overlap) +defaultTokenSplitterOps :: TokenSplitterOps +defaultTokenSplitterOps = + TokenSplitterOps + { maxTokens = 500 + , tokenOverlap = 50 + , tokenCounter = countTokensApprox + } + +-- | Split text into chunks bounded by maxTokens +splitByTokens :: TokenSplitterOps -> Text -> [Text] +splitByTokens _ "" = [] +splitByTokens ops text = + let wordsList = T.words text + in if null wordsList + then [] + else go [] [] wordsList + where + maxT = maxTokens ops + overlapT = tokenOverlap ops + count = tokenCounter ops + + go :: [Text] -> [Text] -> [Text] -> [Text] + go acc currentWords [] = + if null currentWords + then reverse acc + else reverse (T.unwords (reverse currentWords) : acc) + go acc currentWords (w : ws) = + let candidate = T.unwords (reverse (w : currentWords)) + tokCount = count candidate + in if tokCount <= maxT + then go acc (w : currentWords) ws + else + let finishedChunk = T.unwords (reverse currentWords) + newAcc = finishedChunk : acc + -- Overlap words + overlapWords = takeOverlap overlapT (reverse currentWords) [] + in go newAcc (w : overlapWords) ws + + takeOverlap :: Int -> [Text] -> [Text] -> [Text] + takeOverlap _ [] acc = acc + takeOverlap target (pw : pws) acc = + let candidate = T.unwords (pw : acc) + in if count candidate <= target + then takeOverlap target pws (pw : acc) + else if null acc then [pw] else acc diff --git a/src/Langchain/Tool.hs b/src/Langchain/Tool.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Tool.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Langchain.Tool +Description : Effect-polymorphic Tool specification and parameter validation +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Provides effect-polymorphic 'Tool m' representation, schema generation, and argument parsing. +-} +module Langchain.Tool + ( Tool (..) + , createTool + , toolToValue + ) where + +import Data.Aeson +import Data.Text (Text) + +import Langchain.Error (LangchainError) + +-- | Effect-polymorphic Tool abstraction +data Tool m = Tool + { toolName :: Text + -- ^ Unique identifier for the tool + , toolDescription :: Text + -- ^ Description explaining when and how to use the tool + , toolSchema :: Value + -- ^ JSON Schema describing expected parameters + , toolExecute :: Value -> m (Either LangchainError Text) + -- ^ Monadic execution function accepting JSON arguments and returning text output + } + +instance Show (Tool m) where + show t = "Tool { toolName = " ++ show (toolName t) ++ " }" + +-- | Helper to create a Tool from a name, description, schema, and execution function +createTool :: + Text -> + Text -> + Value -> + (Value -> m (Either LangchainError Text)) -> + Tool m +createTool name desc schema execFn = + Tool + { toolName = name + , toolDescription = desc + , toolSchema = schema + , toolExecute = execFn + } + +-- | Convert Tool definition to OpenAI/Ollama compatible function definition JSON object +toolToValue :: Tool m -> Value +toolToValue Tool {..} = + object + [ "type" .= ("function" :: Text) + , "function" + .= object + [ "name" .= toolName + , "description" .= toolDescription + , "parameters" .= toolSchema + ] + ] diff --git a/src/Langchain/Tool/Binding.hs b/src/Langchain/Tool/Binding.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Tool/Binding.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | +Module : Langchain.Tool.Binding +Description : Typeclass for attaching tool definitions to provider-specific model configs +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Provides 'ToolBinder' typeclass enabling agents to attach tool definitions +to provider-specific 'ModelConfig' types in a uniform way. This is the bridge +between provider-agnostic agent code and provider-specific tool APIs. +-} +module Langchain.Tool.Binding + ( ToolBinder (..) + ) where + +import Langchain.Model (ChatModel (..)) +import Langchain.Tool (Tool) + +{- | Typeclass for models that support binding tools into their 'ModelConfig'. + +Agents like @ReActAgent@ use this to pass tool definitions to the LLM +provider in a provider-agnostic way. + += Example + +@ +-- Agent code (provider-agnostic): +let cfg = bindToolsConfig tools Nothing +responseMsg <- invoke model history cfg + +-- The right thing happens automatically: +-- For Ollama: builds an OllamaConfig with ollamaTools set +-- For OpenAI: builds a Value with "tools" key +-- For OllamaWithTools: merges into existing config +@ +-} +class (ChatModel model) => ToolBinder model m where + {- | Convert a list of tools into a provider-specific 'ModelConfig', + optionally merging with an existing config. + -} + bindToolsConfig :: [Tool m] -> Maybe (ModelConfig model) -> Maybe (ModelConfig model) diff --git a/src/Langchain/Tool/Checkpoint.hs b/src/Langchain/Tool/Checkpoint.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Tool/Checkpoint.hs @@ -0,0 +1,308 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.Tool.Checkpoint +Description : Undo checkpoints, file snapshots, and audit log tracking for tool calls +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Provides transactional undo snapshots before file modifications, audit logging of tool calls, +and read-before-edit verification. +-} +module Langchain.Tool.Checkpoint + ( -- * Types + FileCheckpoint (..) + , ToolAuditEntry (..) + , CheckpointRegistry (..) + + -- * Registry Operations + , newCheckpointRegistry + , recordFileRead + , hasReadFile + , createFileCheckpoint + , rollbackCheckpoint + , recordAuditEntry + , getAuditHistory + , listCheckpoints + + -- * Tools + , undoFileEditTool + , listCheckpointsTool + ) where + +import Control.Concurrent.STM + ( TVar + , atomically + , modifyTVar' + , newTVarIO + , readTVar + , readTVarIO + , writeTVar + ) +import Control.Exception (try) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (FromJSON, ToJSON, Value (..), object, (.:?), (.=)) +import Data.Aeson.Types (parseEither) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Data.Time.Clock (UTCTime, getCurrentTime) +import GHC.Generics (Generic) +import System.Directory (canonicalizePath, doesFileExist) +import System.FilePath (normalise) + +import Langchain.Error (LangchainError, toolError) +import Langchain.Tool (Tool (..), createTool) +import Langchain.Tool.Security (ToolTier (..)) + +-- | Represents an automatic undo snapshot taken before a file was modified. +data FileCheckpoint = FileCheckpoint + { cpId :: !Text + -- ^ Unique checkpoint identifier (e.g. @"cp-1"@) + , cpTimestamp :: !UTCTime + -- ^ Time when the snapshot was recorded + , cpFilePath :: !FilePath + -- ^ Canonical path of the modified file + , cpPreviousContent :: !Text + -- ^ File content before the modification + , cpDescription :: !Text + -- ^ Operation description (e.g. @"edit_file: replace 'foo' with 'bar'"@) + } + deriving (Eq, Show, Generic, ToJSON, FromJSON) + +-- | Audit trail record for a single tool call. +data ToolAuditEntry = ToolAuditEntry + { auditStep :: !Int + -- ^ Step index of the tool call + , auditTimestamp :: !UTCTime + -- ^ Timestamp of invocation + , auditToolName :: !Text + -- ^ Name of tool executed + , auditArguments :: !Value + -- ^ Arguments supplied to the tool + , auditResult :: !(Either Text Text) + -- ^ Execution result (Left error or Right output) + , auditTier :: !ToolTier + -- ^ Permission tier of the tool + } + deriving (Eq, Show, Generic, ToJSON, FromJSON) + +-- | Stateful in-memory STM registry tracking file checkpoints, audit history, and inspected files. +data CheckpointRegistry = CheckpointRegistry + { regFileCheckpoints :: !(TVar [FileCheckpoint]) + , regAuditLog :: !(TVar [ToolAuditEntry]) + , regReadFiles :: !(TVar (Set.Set FilePath)) + , regNextId :: !(TVar Int) + } + +-- | Initialize a new in-memory checkpoint and audit registry. +newCheckpointRegistry :: IO CheckpointRegistry +newCheckpointRegistry = do + cpsVar <- newTVarIO [] + audVar <- newTVarIO [] + readVar <- newTVarIO Set.empty + idVar <- newTVarIO 1 + pure $ CheckpointRegistry cpsVar audVar readVar idVar + +-- | Normalize a path for read-tracking lookups. +normalizeForTracking :: FilePath -> IO FilePath +normalizeForTracking fp = do + exists <- doesFileExist fp + if exists + then canonicalizePath fp + else pure (normalise fp) + +-- | Record that a file was read by the agent (for read-before-edit verification). +recordFileRead :: CheckpointRegistry -> FilePath -> IO () +recordFileRead CheckpointRegistry {..} rawPath = do + normPath <- normalizeForTracking rawPath + atomically $ modifyTVar' regReadFiles (Set.insert normPath) + +-- | Check whether a file was previously inspected via read_file. +hasReadFile :: CheckpointRegistry -> FilePath -> IO Bool +hasReadFile CheckpointRegistry {..} rawPath = do + normPath <- normalizeForTracking rawPath + readsSet <- readTVarIO regReadFiles + pure $ Set.member normPath readsSet + +-- | Capture an undo snapshot before modifying or writing a file. +createFileCheckpoint :: + CheckpointRegistry -> + FilePath -> + Text -> + Text -> + IO Text +createFileCheckpoint CheckpointRegistry {..} rawPath prevContent desc = do + normPath <- normalizeForTracking rawPath + now <- getCurrentTime + atomically $ do + currId <- readTVar regNextId + writeTVar regNextId (currId + 1) + let cpIdentifier = "cp-" <> T.pack (show currId) + checkpoint = + FileCheckpoint + { cpId = cpIdentifier + , cpTimestamp = now + , cpFilePath = normPath + , cpPreviousContent = prevContent + , cpDescription = desc + } + modifyTVar' regFileCheckpoints (checkpoint :) + pure cpIdentifier + +{- | Roll back a file to its previous checkpoint content. + +If no 'cpId' is specified, reverts the most recent checkpoint. +-} +rollbackCheckpoint :: + CheckpointRegistry -> + Maybe Text -> + IO (Either LangchainError Text) +rollbackCheckpoint CheckpointRegistry {..} mbTargetId = do + mCp <- atomically $ do + cps <- readTVar regFileCheckpoints + case mbTargetId of + Nothing -> case cps of + [] -> pure Nothing + (latest : rest) -> do + writeTVar regFileCheckpoints rest + pure (Just latest) + Just targetId -> + case break (\c -> cpId c == targetId) cps of + (_, []) -> pure Nothing + (before, target : after) -> do + writeTVar regFileCheckpoints (before ++ after) + pure (Just target) + + case mCp of + Nothing -> + pure $ + Left $ + toolError + ( case mbTargetId of + Nothing -> "No checkpoints available to roll back." + Just tid -> "Checkpoint '" <> tid <> "' not found in registry." + ) + (Just "undo_file_edit") + Nothing + Just FileCheckpoint {..} -> do + eWrite <- try (TIO.writeFile cpFilePath cpPreviousContent) + case eWrite of + Left err -> + pure $ + Left $ + toolError + ("Failed to restore file during rollback: " <> T.pack (show (err :: IOError))) + (Just "undo_file_edit") + Nothing + Right () -> + pure $ + Right $ + "Successfully restored '" + <> T.pack cpFilePath + <> "' to checkpoint [" + <> cpId + <> "] (" + <> cpDescription + <> ")." + +-- | Record a completed tool call into the audit log. +recordAuditEntry :: + CheckpointRegistry -> + Text -> + Value -> + Either Text Text -> + ToolTier -> + IO () +recordAuditEntry CheckpointRegistry {..} toolNm args res tier = do + now <- getCurrentTime + atomically $ do + step <- readTVar regNextId + let entry = + ToolAuditEntry + { auditStep = step + , auditTimestamp = now + , auditToolName = toolNm + , auditArguments = args + , auditResult = res + , auditTier = tier + } + modifyTVar' regAuditLog (entry :) + +-- | Retrieve all audit log entries in chronological order. +getAuditHistory :: CheckpointRegistry -> IO [ToolAuditEntry] +getAuditHistory CheckpointRegistry {..} = reverse <$> readTVarIO regAuditLog + +-- | Retrieve all available file checkpoints. +listCheckpoints :: CheckpointRegistry -> IO [FileCheckpoint] +listCheckpoints CheckpointRegistry {..} = readTVarIO regFileCheckpoints + +-- | Tool that rolls back a file modification to a previous checkpoint. +undoFileEditTool :: MonadIO m => CheckpointRegistry -> Tool m +undoFileEditTool registry = + createTool + "undo_file_edit" + "Revert a file to its previous state before an edit or write operation was performed. Reverts the most recent edit by default, or a specific checkpoint_id." + ( object + [ "type" .= ("object" :: Text) + , "properties" + .= object + [ "checkpoint_id" + .= object + [ "type" .= ("string" :: Text) + , "description" + .= ( "Optional checkpoint ID (e.g. 'cp-1') to revert to. If omitted, rolls back the most recent edit." :: + Text + ) + ] + ] + ] + ) + ( \case + Object o -> do + let mbId = case parseEither (.:? "checkpoint_id") o of + Right m -> m + _ -> Nothing + liftIO $ rollbackCheckpoint registry mbId + _ -> liftIO $ rollbackCheckpoint registry Nothing + ) + +-- | Tool that lists all active undo checkpoints. +listCheckpointsTool :: MonadIO m => CheckpointRegistry -> Tool m +listCheckpointsTool registry = + createTool + "list_checkpoints" + "List all available file modification checkpoints that can be reverted." + ( object + [ "type" .= ("object" :: Text) + , "properties" .= object [] + ] + ) + ( \_ -> liftIO $ do + cps <- listCheckpoints registry + if null cps + then pure $ Right "No active file checkpoints." + else + let linesFormatted = + map + ( \FileCheckpoint {..} -> + "[" + <> cpId + <> "] " + <> T.pack cpFilePath + <> " — " + <> cpDescription + <> " (" + <> T.pack (show cpTimestamp) + <> ")" + ) + cps + in pure $ Right $ T.unlines ("Active Checkpoints:" : linesFormatted) + ) diff --git a/src/Langchain/Tool/Core.hs b/src/Langchain/Tool/Core.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Tool/Core.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE FlexibleContexts #-} + +{- | +Module : Langchain.Tool.Core +Description : Re-exports effect-polymorphic Tool from langchain-hs-core +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Re-exports 'Tool m', 'createTool', and 'toolToValue'. +-} +module Langchain.Tool.Core + ( module Langchain.Tool + ) where + +import Langchain.Tool diff --git a/src/Langchain/Tool/FileSystem.hs b/src/Langchain/Tool/FileSystem.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Tool/FileSystem.hs @@ -0,0 +1,914 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- | +Module : Langchain.Tool.FileSystem +Description : Observational and state-modifying filesystem tools +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Provides comprehensive, agent-optimized filesystem tools: +* 'findFilesTool' ('find_files'): Concurrent directory search respecting .gitignore, depth, and patterns. +* 'grepSearchTool' ('grep_search'): High-performance ripgrep-style content search with line numbers and context-window protection. +* 'readFileTool' ('read_file'): Paginated reading with line numbers, context-window awareness, and read-before-edit tracking. +* 'editFileTool' ('edit_file'): Precise string replacement with read-before-edit verification, uniqueness check, and automatic undo snapshots. +* 'writeFileTool' ('write_file'): Safe file creation with overwrite protection and automatic checkpointing. +* 'listDirTool' ('list_directory'): Directory inspection with file sizes and type indicators. +* 'newFileSystemSuite': Factory creating the complete suite sharing a checkpoint registry and security policy. +-} +module Langchain.Tool.FileSystem + ( -- * Complete Suite Factory + newFileSystemSuite + + -- * Observational Tools + , findFilesTool + , grepSearchTool + , readFileTool + , listDirTool + + -- * Modification Tools + , editFileTool + , writeFileTool + + -- * Helper / Pure Matching + , matchGlobPattern + , isDefaultIgnored + ) where + +import Control.Concurrent.Async (mapConcurrently) +import Control.Exception (SomeException, try) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (FromJSON, Key, Object, Value (..), object, (.:?), (.=)) +import Data.Aeson.Types (parseEither) +import Data.Char (toLower) +import Data.List (isInfixOf, isPrefixOf, isSuffixOf, sort) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO + +import System.Directory + ( createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , getFileSize + , listDirectory + ) +import System.FilePath + ( takeDirectory + , takeFileName + , () + ) + +import Langchain.Error (toolError) +import Langchain.Tool (Tool (..), createTool) +import Langchain.Tool.Checkpoint + ( CheckpointRegistry + , createFileCheckpoint + , hasReadFile + , listCheckpointsTool + , newCheckpointRegistry + , recordFileRead + , undoFileEditTool + ) +import Langchain.Tool.Security + ( SecurityPolicy + , ToolTier (..) + , validateSandboxPath + , withSecurity + ) + +-- | Extract an optional JSON field with a fallback default. +optField :: FromJSON a => Key -> a -> Object -> a +optField k def o = case parseEither (.:? k) o of + Right (Just v) -> v + _ -> def + +-- | Extract an optional JSON field as Maybe. +mbField :: FromJSON a => Key -> Object -> Maybe a +mbField k o = case parseEither (.:? k) o of + Right mv -> mv + _ -> Nothing + +-- ============================================================================ +-- Pure Pattern & Gitignore Matching +-- ============================================================================ + +-- | Directories and file suffixes automatically ignored in find and search. +defaultIgnoredNames :: [String] +defaultIgnoredNames = + [ ".git" + , ".stack-work" + , "dist-newstyle" + , "node_modules" + , ".cabal-sandbox" + , ".idea" + , ".vscode" + , ".DS_Store" + ] + +-- | Check if a directory or filename is in the default ignore set. +isDefaultIgnored :: FilePath -> Bool +isDefaultIgnored name = + let fn = takeFileName name + in fn `elem` defaultIgnoredNames || ".git" `isPrefixOf` fn + +-- | Simple glob matcher supporting '*' wildcard and case-insensitivity. +matchGlobPattern :: String -> String -> Bool +matchGlobPattern pat str + | null pat = True + | pat == "*" = True + | "*" `isPrefixOf` pat && "*" `isSuffixOf` pat = + let sub = drop 1 (take (length pat - 1) pat) + in map toLower sub `isInfixOf` map toLower str + | "*" `isPrefixOf` pat = + let sfx = drop 1 pat + in map toLower sfx `isSuffixOf` map toLower str + | "*" `isSuffixOf` pat = + let pfx = take (length pat - 1) pat + in map toLower pfx `isPrefixOf` map toLower str + | "*" `isInfixOf` pat = + let (before, afterStar) = span (/= '*') pat + after = drop 1 afterStar + in (map toLower before `isPrefixOf` map toLower str) + && (map toLower after `isSuffixOf` map toLower str) + | otherwise = + map toLower pat `isInfixOf` map toLower str + +-- ============================================================================ +-- 1. Find Files Tool +-- ============================================================================ + +-- | Create a concurrent file/directory search tool. +findFilesTool :: + MonadIO m => + SecurityPolicy -> + Tool m +findFilesTool policy = + withSecurity TierReadOnly policy $ + createTool + "find_files" + "Search for files and directories matching name patterns with recursion depth control, gitignore filtering, and concurrent scanning." + ( object + [ "type" .= ("object" :: Text) + , "properties" + .= object + [ "path" + .= object + [ "type" .= ("string" :: Text) + , "description" .= ("Root directory to start searching from (default: '.')" :: Text) + ] + , "pattern" + .= object + [ "type" .= ("string" :: Text) + , "description" .= ("Filename or glob pattern to match (e.g. '*.hs', 'Spec', 'test*')" :: Text) + ] + , "max_depth" + .= object + [ "type" .= ("integer" :: Text) + , "description" .= ("Maximum recursion directory depth (default: unlimited)" :: Text) + ] + , "file_type" + .= object + [ "type" .= ("string" :: Text) + , "description" .= ("Filter results by 'file', 'directory', or 'any' (default: 'any')" :: Text) + ] + , "max_results" + .= object + [ "type" .= ("integer" :: Text) + , "description" .= ("Maximum number of matching paths to return (default: 100)" :: Text) + ] + ] + ] + ) + ( \case + Object o -> do + let rawPath = optField "path" "." o :: String + pat = optField "pattern" "" o :: String + mbMaxDepth = mbField "max_depth" o :: Maybe Int + fType = optField "file_type" "any" o :: Text + maxResults = optField "max_results" 100 o :: Int + + eCleanPath <- validateSandboxPath policy rawPath + case eCleanPath of + Left err -> pure $ Left err + Right cleanPath -> do + eMatches <- liftIO $ try (walkFind cleanPath pat mbMaxDepth fType maxResults 0) + case eMatches of + Left err -> + pure $ + Left $ + toolError + ("Failed searching directory: " <> T.pack (show (err :: SomeException))) + (Just "find_files") + Nothing + Right (found, truncated) -> + let count = length found + header = + "Found " + <> T.pack (show count) + <> " items" + <> (if truncated then " (truncated at " <> T.pack (show maxResults) <> ")" else "") + <> ":" + formatted = map T.pack found + in pure $ Right $ T.unlines (header : formatted) + _ -> pure $ Left $ toolError "Invalid arguments object" (Just "find_files") Nothing + ) + where + walkFind :: FilePath -> String -> Maybe Int -> Text -> Int -> Int -> IO ([FilePath], Bool) + walkFind dir pat mbMaxDepth fType limit currentDepth = do + isDir <- doesDirectoryExist dir + if not isDir + then pure ([], False) + else do + entries <- listDirectory dir + let filtered = filter (not . isDefaultIgnored) entries + let fullPaths = map (dir ) filtered + + let matchesPat p = null pat || matchGlobPattern pat (takeFileName p) + + -- Separate files and subdirectories + (files, subdirs) <- partitionPaths fullPaths + + let matchingFiles = + if fType `elem` ["any", "file"] + then filter matchesPat files + else [] + matchingDirs = + if fType `elem` ["any", "directory"] + then filter matchesPat subdirs + else [] + currentMatches = matchingFiles ++ matchingDirs + + let canRecurse = maybe True (currentDepth <) mbMaxDepth + if not canRecurse || length currentMatches >= limit + then pure (take limit currentMatches, length currentMatches >= limit) + else do + let remainingLimit = limit - length currentMatches + subResults <- + mapConcurrently + (\sd -> walkFind sd pat mbMaxDepth fType remainingLimit (currentDepth + 1)) + subdirs + let (allSubMatches, anyTrunc) = mconcatResults subResults + combined = currentMatches ++ allSubMatches + pure (take limit combined, anyTrunc || length combined >= limit) + + partitionPaths :: [FilePath] -> IO ([FilePath], [FilePath]) + partitionPaths paths = do + dirFlags <- mapConcurrently doesDirectoryExist paths + let (dirs, files) = + foldr + ( \(p, isD) (ds, fs) -> + if isD then (p : ds, fs) else (ds, p : fs) + ) + ([], []) + (zip paths dirFlags) + pure (files, dirs) + + mconcatResults :: [([FilePath], Bool)] -> ([FilePath], Bool) + mconcatResults xs = (concatMap fst xs, any snd xs) + +-- ============================================================================ +-- 2. Grep Search Tool +-- ============================================================================ + +-- | Ripgrep-style content search tool. +grepSearchTool :: + MonadIO m => + SecurityPolicy -> + Tool m +grepSearchTool policy = + withSecurity TierReadOnly policy $ + createTool + "grep_search" + "Search file contents across the workspace with line numbers, regex or literal search, context lines, and context-window protection." + ( object + [ "type" .= ("object" :: Text) + , "properties" + .= object + [ "path" + .= object + [ "type" .= ("string" :: Text) + , "description" .= ("Directory or file path to search (default: '.')" :: Text) + ] + , "query" + .= object + [ "type" .= ("string" :: Text) + , "description" .= ("The text string to find" :: Text) + ] + , "case_sensitive" + .= object + [ "type" .= ("boolean" :: Text) + , "description" .= ("Perform case-sensitive search (default: false)" :: Text) + ] + , "include_glob" + .= object + [ "type" .= ("string" :: Text) + , "description" .= ("Optional filename glob filter, e.g. '*.hs' or '*.md'" :: Text) + ] + , "context_lines" + .= object + [ "type" .= ("integer" :: Text) + , "description" + .= ("Surrounding context lines to include before/after each match (default: 0)" :: Text) + ] + , "max_results" + .= object + [ "type" .= ("integer" :: Text) + , "description" .= ("Maximum total matches to return before truncation (default: 50)" :: Text) + ] + ] + , "required" .= (["query"] :: [Text]) + ] + ) + ( \case + Object o -> do + let rawPath = optField "path" "." o :: String + query = optField "query" "" o :: Text + caseSens = optField "case_sensitive" False o :: Bool + mbGlob = mbField "include_glob" o :: Maybe String + contextLines = optField "context_lines" 0 o :: Int + maxResults = optField "max_results" 50 o :: Int + + if T.null query + then pure $ Left $ toolError "Search 'query' cannot be empty." (Just "grep_search") Nothing + else do + eCleanPath <- validateSandboxPath policy rawPath + case eCleanPath of + Left err -> pure $ Left err + Right cleanPath -> do + eRes <- liftIO $ try (runGrep cleanPath query caseSens mbGlob contextLines maxResults) + case eRes of + Left err -> + pure $ + Left $ + toolError + ("Grep search failed: " <> T.pack (show (err :: SomeException))) + (Just "grep_search") + Nothing + Right resultText -> pure $ Right resultText + _ -> pure $ Left $ toolError "Invalid arguments object" (Just "grep_search") Nothing + ) + where + runGrep :: FilePath -> Text -> Bool -> Maybe String -> Int -> Int -> IO Text + runGrep root query caseSens mbGlob ctxLines limit = do + isDir <- doesDirectoryExist root + files <- + if isDir + then collectSearchFiles root mbGlob + else pure [root] + + fileResults <- + mapConcurrently + (\f -> searchSingleFile f query caseSens ctxLines) + files + + let allMatches = concatMap snd fileResults + totalCount = length allMatches + shownMatches = take limit allMatches + wasTruncated = totalCount > limit + header = + "Found " + <> T.pack (show totalCount) + <> " match" + <> (if totalCount == 1 then "" else "es") + <> (if wasTruncated then " (showing first " <> T.pack (show limit) <> ")" else "") + <> ":" + + if null allMatches + then pure ("No matches found for '" <> query <> "' in " <> T.pack root) + else pure $ T.unlines (header : shownMatches) + + collectSearchFiles :: FilePath -> Maybe String -> IO [FilePath] + collectSearchFiles dir mbGlob = do + entries <- listDirectory dir + let valid = filter (not . isDefaultIgnored) entries + fulls = map (dir ) valid + (files, subdirs) <- partitionPaths fulls + let matchingFiles = case mbGlob of + Nothing -> files + Just glob -> filter (matchGlobPattern glob . takeFileName) files + subFiles <- mapConcurrently (`collectSearchFiles` mbGlob) subdirs + pure (matchingFiles ++ concat subFiles) + + partitionPaths :: [FilePath] -> IO ([FilePath], [FilePath]) + partitionPaths paths = do + flags <- mapConcurrently doesDirectoryExist paths + let (ds, fs) = + foldr + (\(p, isD) (dAcc, fAcc) -> if isD then (p : dAcc, fAcc) else (dAcc, p : fAcc)) + ([], []) + (zip paths flags) + pure (fs, ds) + + searchSingleFile :: FilePath -> Text -> Bool -> Int -> IO (FilePath, [Text]) + searchSingleFile path query caseSens ctx = do + eTxt <- try (TIO.readFile path) + case eTxt of + Left (_ :: IOError) -> pure (path, []) + Right content -> do + let allLines = zip [1 :: Int ..] (T.lines content) + isMatch (_, line) = + if caseSens + then query `T.isInfixOf` line + else T.toLower query `T.isInfixOf` T.toLower line + matchingIndices = [idx | (idx, l) <- allLines, isMatch (idx, l)] + + if null matchingIndices + then pure (path, []) + else do + let blocks = + map + ( \matchIdx -> + if ctx == 0 + then case lookup matchIdx allLines of + Just l -> T.pack path <> ":" <> T.pack (show matchIdx) <> ": " <> l + Nothing -> T.pack path <> ":" <> T.pack (show matchIdx) <> ":" + else + let start = max 1 (matchIdx - ctx) + end = min (length allLines) (matchIdx + ctx) + slice = filter (\(i, _) -> i >= start && i <= end) allLines + in T.unlines + ( (T.pack path <> ":") + : [ " " + <> T.pack (show lineNum) + <> (if lineNum == matchIdx then ": " else "| ") + <> lineTxt + | (lineNum, lineTxt) <- slice + ] + ) + ) + matchingIndices + pure (path, blocks) + +-- ============================================================================ +-- 3. Read File Tool (Paginated, Line-Numbered, Read-before-edit Enforced) +-- ============================================================================ + +-- | Read file tool with line-based pagination and context-window protection. +readFileTool :: + MonadIO m => + Maybe CheckpointRegistry -> + SecurityPolicy -> + Tool m +readFileTool mbRegistry policy = + withSecurity TierReadOnly policy $ + createTool + "read_file" + "Read text contents of a file with line-based pagination, context-window awareness, line numbering, and security checks." + ( object + [ "type" .= ("object" :: Text) + , "properties" + .= object + [ "path" + .= object + [ "type" .= ("string" :: Text) + , "description" .= ("Path to the file to read" :: Text) + ] + , "start_line" + .= object + [ "type" .= ("integer" :: Text) + , "description" .= ("Optional 1-indexed starting line number (default: 1)" :: Text) + ] + , "end_line" + .= object + [ "type" .= ("integer" :: Text) + , "description" .= ("Optional 1-indexed ending line number (default: start_line + 250)" :: Text) + ] + ] + , "required" .= (["path"] :: [Text]) + ] + ) + ( \case + Object o -> do + let rawPath = optField "path" "" o :: String + mbStart = mbField "start_line" o :: Maybe Int + mbEnd = mbField "end_line" o :: Maybe Int + + if null rawPath + then pure $ Left $ toolError "Missing 'path' parameter" (Just "read_file") Nothing + else do + eCleanPath <- validateSandboxPath policy rawPath + case eCleanPath of + Left err -> pure $ Left err + Right cleanPath -> do + eContent <- liftIO $ try (TIO.readFile cleanPath) + case eContent of + Left err -> + pure $ + Left $ + toolError + ("Failed reading file: " <> T.pack (show (err :: IOError))) + (Just "read_file") + Nothing + Right fullContent -> do + -- Record file inspection in CheckpointRegistry for read-before-edit verification + case mbRegistry of + Nothing -> pure () + Just reg -> liftIO $ recordFileRead reg cleanPath + + let fileLines = T.lines fullContent + totalLines = length fileLines + start = max 1 (fromMaybe 1 mbStart) + defaultEnd = min totalLines (start + 249) + end = min totalLines (fromMaybe defaultEnd mbEnd) + selectedLines = + take (end - start + 1) $ + drop (start - 1) fileLines + numbered = + zipWith + (\n l -> T.pack (show n) <> ": " <> l) + [start .. end] + selectedLines + + hasMore = end < totalLines + header = + "[File: " + <> T.pack cleanPath + <> " | Lines " + <> T.pack (show start) + <> "-" + <> T.pack (show end) + <> " of " + <> T.pack (show totalLines) + <> "]" + footer = + if hasMore + then + "\n[Showing " + <> T.pack (show (end - start + 1)) + <> " lines. Call read_file with start_line=" + <> T.pack (show (end + 1)) + <> " to view subsequent lines]" + else "" + pure $ Right $ T.unlines (header : numbered) <> footer + _ -> pure $ Left $ toolError "Invalid arguments object" (Just "read_file") Nothing + ) + +-- ============================================================================ +-- 4. Edit File Tool (Uniqueness Check, Read-Before-Edit, Checkpointing) +-- ============================================================================ + +-- | Precise string replacement tool with uniqueness check and automatic checkpointing. +editFileTool :: + MonadIO m => + Maybe CheckpointRegistry -> + SecurityPolicy -> + Tool m +editFileTool mbRegistry policy = + withSecurity TierWorkspaceWrite policy $ + createTool + "edit_file" + "Perform precise string replacement in a file. Enforces read-before-edit verification, exact uniqueness check, and automatic undo checkpointing." + ( object + [ "type" .= ("object" :: Text) + , "properties" + .= object + [ "path" + .= object + [ "type" .= ("string" :: Text) + , "description" .= ("Path to the file to edit" :: Text) + ] + , "old_string" + .= object + [ "type" .= ("string" :: Text) + , "description" + .= ("Exact character sequence to be replaced (must match uniquely in the file)" :: Text) + ] + , "new_string" + .= object + [ "type" .= ("string" :: Text) + , "description" .= ("Replacement text to insert" :: Text) + ] + , "expected_occurrences" + .= object + [ "type" .= ("integer" :: Text) + , "description" .= ("Expected number of occurrences to replace (default: 1)" :: Text) + ] + ] + , "required" .= (["path", "old_string", "new_string"] :: [Text]) + ] + ) + ( \case + Object o -> do + let rawPath = optField "path" "" o :: String + oldStr = optField "old_string" "" o :: Text + newStr = optField "new_string" "" o :: Text + expectedOccs = optField "expected_occurrences" 1 o :: Int + + if null rawPath + then pure $ Left $ toolError "Missing 'path' parameter" (Just "edit_file") Nothing + else + if T.null oldStr + then pure $ Left $ toolError "'old_string' cannot be empty" (Just "edit_file") Nothing + else do + eCleanPath <- validateSandboxPath policy rawPath + case eCleanPath of + Left err -> pure $ Left err + Right cleanPath -> do + -- 1. Read-before-edit verification + hasRead <- case mbRegistry of + Nothing -> pure True + Just reg -> liftIO $ hasReadFile reg cleanPath + + if not hasRead + then + pure $ + Left $ + toolError + ( "Read-before-edit policy violation: You must inspect '" + <> T.pack cleanPath + <> "' using 'read_file' before editing it. This ensures exact line content and surrounding context." + ) + (Just "edit_file") + Nothing + else do + -- 2. Read existing content + eCurrent <- liftIO $ try (TIO.readFile cleanPath) + case eCurrent of + Left err -> + pure $ + Left $ + toolError + ("Failed reading target file: " <> T.pack (show (err :: IOError))) + (Just "edit_file") + Nothing + Right currentTxt -> do + -- 3. Uniqueness and occurrence check + let occCount = countOccurrences oldStr currentTxt + if occCount == 0 + then + pure $ + Left $ + toolError + ( "Target content not found in '" + <> T.pack cleanPath + <> "'. Ensure exact whitespace and line indentation by checking 'read_file'." + ) + (Just "edit_file") + Nothing + else + if occCount /= expectedOccs + then do + let lineIndices = findOccurrencesLineIndices oldStr currentTxt + pure $ + Left $ + toolError + ( "Ambiguity error: Expected " + <> T.pack (show expectedOccs) + <> " occurrence(s), but found " + <> T.pack (show occCount) + <> " occurrences in '" + <> T.pack cleanPath + <> "' at lines: " + <> T.pack (show lineIndices) + <> ". Please include more surrounding lines in 'old_string' to make it unique." + ) + (Just "edit_file") + Nothing + else do + -- 4. Automatic undo snapshot checkpoint + cpIdText <- case mbRegistry of + Nothing -> pure "no-registry" + Just reg -> + liftIO $ + createFileCheckpoint + reg + cleanPath + currentTxt + ("edit_file (" <> T.pack (show expectedOccs) <> " replacements)") + + -- 5. Apply replacement + let replacedTxt = T.replace oldStr newStr currentTxt + eWrite <- liftIO $ try (TIO.writeFile cleanPath replacedTxt) + case eWrite of + Left err -> + pure $ + Left $ + toolError + ("Failed writing edited file: " <> T.pack (show (err :: IOError))) + (Just "edit_file") + Nothing + Right () -> + pure $ + Right $ + "Successfully edited '" + <> T.pack cleanPath + <> "' (replaced " + <> T.pack (show occCount) + <> " occurrence(s)). Checkpoint ID: [" + <> cpIdText + <> "]. Use 'undo_file_edit' to revert if needed." + _ -> pure $ Left $ toolError "Invalid arguments object" (Just "edit_file") Nothing + ) + where + countOccurrences needle haystack + | T.null needle = 0 + | otherwise = T.count needle haystack + + findOccurrencesLineIndices needle haystack = + let lns = zip [1 :: Int ..] (T.lines haystack) + in [ln | (ln, lineTxt) <- lns, needle `T.isInfixOf` lineTxt] + +-- ============================================================================ +-- 5. Write File Tool +-- ============================================================================ + +-- | Write text to file with overwrite protection and automatic checkpointing. +writeFileTool :: + MonadIO m => + Maybe CheckpointRegistry -> + SecurityPolicy -> + Tool m +writeFileTool mbRegistry policy = + withSecurity TierWorkspaceWrite policy $ + createTool + "write_file" + "Write text contents to a file path. Automatically creates parent directories. Protects against accidental overwrites and takes undo checkpoints." + ( object + [ "type" .= ("object" :: Text) + , "properties" + .= object + [ "path" + .= object + [ "type" .= ("string" :: Text) + , "description" .= ("Target destination file path" :: Text) + ] + , "content" + .= object + [ "type" .= ("string" :: Text) + , "description" .= ("Full content to write" :: Text) + ] + , "overwrite" + .= object + [ "type" .= ("boolean" :: Text) + , "description" .= ("Allow overwriting if file already exists (default: false)" :: Text) + ] + ] + , "required" .= (["path", "content"] :: [Text]) + ] + ) + ( \case + Object o -> do + let rawPath = optField "path" "" o :: String + content = optField "content" "" o :: Text + overwrite = optField "overwrite" False o :: Bool + + if null rawPath + then pure $ Left $ toolError "Missing 'path' parameter" (Just "write_file") Nothing + else do + eCleanPath <- validateSandboxPath policy rawPath + case eCleanPath of + Left err -> pure $ Left err + Right cleanPath -> do + exists <- liftIO $ doesFileExist cleanPath + if exists && not overwrite + then + pure $ + Left $ + toolError + ( "File '" + <> T.pack cleanPath + <> "' already exists. Set 'overwrite=true' to overwrite, or use 'edit_file' for targeted modifications." + ) + (Just "write_file") + Nothing + else do + -- Automatic checkpoint before overwrite + cpIdText <- + if exists + then case mbRegistry of + Nothing -> pure "no-registry" + Just reg -> do + prevTxt <- liftIO $ TIO.readFile cleanPath + liftIO $ createFileCheckpoint reg cleanPath prevTxt "write_file overwrite" + else pure "new-file" + + liftIO $ createDirectoryIfMissing True (takeDirectory cleanPath) + eWrite <- liftIO $ try (TIO.writeFile cleanPath content) + case eWrite of + Left err -> + pure $ + Left $ + toolError + ("Failed writing file: " <> T.pack (show (err :: IOError))) + (Just "write_file") + Nothing + Right () -> do + -- Mark file as read so subsequent edits can proceed + case mbRegistry of + Nothing -> pure () + Just reg -> liftIO $ recordFileRead reg cleanPath + + pure $ + Right $ + "Successfully wrote file '" + <> T.pack cleanPath + <> "'" + <> (if exists then " (Checkpoint: [" <> cpIdText <> "])" else "") + _ -> pure $ Left $ toolError "Invalid arguments object" (Just "write_file") Nothing + ) + +-- ============================================================================ +-- 6. List Directory Tool +-- ============================================================================ + +-- | List directory contents with entry types and file sizes. +listDirTool :: + MonadIO m => + SecurityPolicy -> + Tool m +listDirTool policy = + withSecurity TierReadOnly policy $ + createTool + "list_directory" + "List files and subdirectories in a directory path with file sizes and type indicators." + ( object + [ "type" .= ("object" :: Text) + , "properties" + .= object + [ "path" + .= object + [ "type" .= ("string" :: Text) + , "description" .= ("Path to directory (default: '.')" :: Text) + ] + ] + ] + ) + ( \case + Object o -> do + let rawPath = optField "path" "." o :: String + eCleanPath <- validateSandboxPath policy rawPath + case eCleanPath of + Left err -> pure $ Left err + Right cleanPath -> do + eList <- liftIO $ try (listDirectory cleanPath) + case eList of + Left err -> + pure $ + Left $ + toolError + ("Failed listing directory: " <> T.pack (show (err :: IOError))) + (Just "list_directory") + Nothing + Right entries -> do + let sorted = sort (filter (not . isDefaultIgnored) entries) + formattedEntries <- liftIO $ mapConcurrently (formatEntry cleanPath) sorted + let count = length sorted + header = + "Directory '" + <> T.pack cleanPath + <> "' (" + <> T.pack (show count) + <> " items):" + pure $ Right $ T.unlines (header : formattedEntries) + _ -> pure $ Left $ toolError "Invalid arguments object" (Just "list_directory") Nothing + ) + where + formatEntry :: FilePath -> FilePath -> IO Text + formatEntry parent name = do + let full = parent name + isDir <- doesDirectoryExist full + if isDir + then pure $ " [DIR] " <> T.pack name <> "/" + else do + sz <- getFileSize full + pure $ + " [FILE] " + <> T.pack name + <> " (" + <> formatBytes sz + <> ")" + + formatBytes :: Integer -> Text + formatBytes b + | b < 1024 = T.pack (show b) <> " B" + | b < 1024 * 1024 = T.pack (show (b `div` 1024)) <> " KB" + | otherwise = T.pack (show (b `div` (1024 * 1024))) <> " MB" + +-- ============================================================================ +-- Complete FileSystem Toolkit Suite Factory +-- ============================================================================ + +{- | Instantiate a complete filesystem toolkit bound to a shared +'CheckpointRegistry' and 'SecurityPolicy'. +-} +newFileSystemSuite :: + MonadIO m => + SecurityPolicy -> + IO [Tool m] +newFileSystemSuite policy = do + registry <- newCheckpointRegistry + pure + [ findFilesTool policy + , grepSearchTool policy + , readFileTool (Just registry) policy + , listDirTool policy + , writeFileTool (Just registry) policy + , editFileTool (Just registry) policy + , undoFileEditTool registry + , listCheckpointsTool registry + ] diff --git a/src/Langchain/Tool/GenericSchema.hs b/src/Langchain/Tool/GenericSchema.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Tool/GenericSchema.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +{- | +Module : Langchain.Tool.GenericSchema +Description : Type-safe tool parameter JSON schema derivation using GHC Generics +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Automatically derives OpenAI-compatible tool JSON schema objects from Haskell record types +using GHC Generics at compile time. +-} +module Langchain.Tool.GenericSchema + ( DeriveToolSchema (..) + , deriveToolParametersSchema + ) where + +import Data.Aeson (Value (..), object, (.=)) +import qualified Data.Aeson.Key as Key +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) +import qualified Data.Map.Strict as Map +import Data.Proxy (Proxy (..)) +import Data.Scientific (Scientific) +import Data.Text (Text) +import qualified Data.Text as TS +import Data.Time (Day, UTCTime) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Generics + +-- | Typeclass for deriving tool JSON schema parameters +class DeriveToolSchema a where + deriveToolSchema :: Proxy a -> Value + default deriveToolSchema :: (GToolRecordSchema (Rep a)) => Proxy a -> Value + deriveToolSchema _ = deriveToolParametersSchema (Proxy :: Proxy a) + +-- | Derive OpenAI tool parameter schema object +deriveToolParametersSchema :: + forall a. (GToolRecordSchema (Rep a)) => Proxy a -> Value +deriveToolParametersSchema _ = + let (props, reqs) = gToolRecordSchema (Proxy :: Proxy (Rep a)) + in object + [ "type" .= ("object" :: Text) + , "properties" .= object props + , "required" .= reqs + ] + +class GToolRecordSchema (f :: Type -> Type) where + gToolRecordSchema :: Proxy f -> ([(Key.Key, Value)], [Text]) + +instance (GToolRecordSchema f, GToolRecordSchema g) => GToolRecordSchema (f :*: g) where + gToolRecordSchema _ = + let (p1, r1) = gToolRecordSchema (Proxy :: Proxy f) + (p2, r2) = gToolRecordSchema (Proxy :: Proxy g) + in (p1 ++ p2, r1 ++ r2) + +instance (GToolRecordSchema f) => GToolRecordSchema (M1 D c f) where + gToolRecordSchema _ = gToolRecordSchema (Proxy :: Proxy f) + +instance (GToolRecordSchema f) => GToolRecordSchema (M1 C c f) where + gToolRecordSchema _ = gToolRecordSchema (Proxy :: Proxy f) + +instance (Selector s, ToolFieldSchema a) => GToolRecordSchema (M1 S s (K1 R a)) where + gToolRecordSchema _ = + let selNameStr = selName (undefined :: M1 S s (K1 R a) p) + propKey = Key.fromString selNameStr + propSchema = toolFieldSchema (Proxy :: Proxy a) + req = [TS.pack selNameStr | not (isOptionalField (Proxy :: Proxy a))] + in ([(propKey, propSchema)], req) + +class ToolFieldSchema a where + toolFieldSchema :: Proxy a -> Value + default toolFieldSchema :: (GToolRecordSchema (Rep a)) => Proxy a -> Value + toolFieldSchema _ = deriveToolParametersSchema (Proxy :: Proxy a) + + isOptionalField :: Proxy a -> Bool + isOptionalField _ = False + +instance ToolFieldSchema Text where + toolFieldSchema _ = object ["type" .= ("string" :: Text)] + +instance ToolFieldSchema String where + toolFieldSchema _ = object ["type" .= ("string" :: Text)] + +instance ToolFieldSchema Char where + toolFieldSchema _ = object ["type" .= ("string" :: Text)] + +instance ToolFieldSchema Int where + toolFieldSchema _ = object ["type" .= ("integer" :: Text)] + +instance ToolFieldSchema Int8 where + toolFieldSchema _ = object ["type" .= ("integer" :: Text)] + +instance ToolFieldSchema Int16 where + toolFieldSchema _ = object ["type" .= ("integer" :: Text)] + +instance ToolFieldSchema Int32 where + toolFieldSchema _ = object ["type" .= ("integer" :: Text)] + +instance ToolFieldSchema Int64 where + toolFieldSchema _ = object ["type" .= ("integer" :: Text)] + +instance ToolFieldSchema Integer where + toolFieldSchema _ = object ["type" .= ("integer" :: Text)] + +instance ToolFieldSchema Word where + toolFieldSchema _ = object ["type" .= ("integer" :: Text)] + +instance ToolFieldSchema Word8 where + toolFieldSchema _ = object ["type" .= ("integer" :: Text)] + +instance ToolFieldSchema Word16 where + toolFieldSchema _ = object ["type" .= ("integer" :: Text)] + +instance ToolFieldSchema Word32 where + toolFieldSchema _ = object ["type" .= ("integer" :: Text)] + +instance ToolFieldSchema Word64 where + toolFieldSchema _ = object ["type" .= ("integer" :: Text)] + +instance ToolFieldSchema Double where + toolFieldSchema _ = object ["type" .= ("number" :: Text)] + +instance ToolFieldSchema Float where + toolFieldSchema _ = object ["type" .= ("number" :: Text)] + +instance ToolFieldSchema Scientific where + toolFieldSchema _ = object ["type" .= ("number" :: Text)] + +instance ToolFieldSchema Bool where + toolFieldSchema _ = object ["type" .= ("boolean" :: Text)] + +instance ToolFieldSchema UTCTime where + toolFieldSchema _ = + object + [ "type" .= ("string" :: Text) + , "format" .= ("date-time" :: Text) + ] + +instance ToolFieldSchema Day where + toolFieldSchema _ = + object + [ "type" .= ("string" :: Text) + , "format" .= ("date" :: Text) + ] + +instance ToolFieldSchema Value where + toolFieldSchema _ = object ["type" .= ("object" :: Text)] + +instance (ToolFieldSchema a) => ToolFieldSchema (Map.Map Text a) where + toolFieldSchema _ = + object + [ "type" .= ("object" :: Text) + , "additionalProperties" .= toolFieldSchema (Proxy :: Proxy a) + ] + +instance (ToolFieldSchema a) => ToolFieldSchema (Maybe a) where + toolFieldSchema _ = toolFieldSchema (Proxy :: Proxy a) + isOptionalField _ = True + +instance {-# OVERLAPPABLE #-} (ToolFieldSchema a) => ToolFieldSchema [a] where + toolFieldSchema _ = + object + [ "type" .= ("array" :: Text) + , "items" .= toolFieldSchema (Proxy :: Proxy a) + ] diff --git a/src/Langchain/Tool/Process.hs b/src/Langchain/Tool/Process.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Tool/Process.hs @@ -0,0 +1,473 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- | +Module : Langchain.Tool.Process +Description : Asynchronous process manager and shell execution tools +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Provides process execution: +* 'commandRunTool' ('command_run'): Runs commands with synchronous wait timeouts, + automatic backgrounding for long-running processes, security checks, and output truncation. +* 'commandStatusTool' ('command_status'): Checks runtime, status, and output logs for running/completed processes. +* 'commandKillTool' ('command_kill'): Cleanly terminates long-running background processes. +* 'newProcessSuite': Instantiates a shared process manager and returns the tool suite. +-} +module Langchain.Tool.Process + ( -- * Process Manager + ProcessManager (..) + , ProcessStatus (..) + , ManagedProcess (..) + , newProcessManager + + -- * Tools + , commandRunTool + , commandStatusTool + , commandKillTool + , newProcessSuite + ) where + +import Control.Concurrent.Async (Async, async, cancel, wait) +import Control.Concurrent.STM + ( TVar + , atomically + , modifyTVar' + , newTVarIO + , readTVar + , readTVarIO + , writeTVar + ) +import Control.Exception (SomeException, try) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (FromJSON (..), Key, Object, ToJSON (..), Value (..), object, (.:?), (.=)) +import Data.Aeson.Types (parseEither) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime) +import GHC.Generics (Generic) +import System.Exit (ExitCode (..)) +import System.IO (hGetLine) +import System.Process + ( CreateProcess (..) + , ProcessHandle + , StdStream (..) + , createProcess + , shell + , terminateProcess + , waitForProcess + ) +import System.Timeout (timeout) + +import Langchain.Error (toolError) +import Langchain.Tool (Tool (..), createTool) +import Langchain.Tool.Security + ( SecurityPolicy + , ToolTier (..) + , validateCommandSafety + , withSecurity + ) + +-- | Execution state of a managed system process. +data ProcessStatus + = StatusRunning + | StatusFinished !ExitCode !UTCTime !NominalDiffTime + | StatusKilled !UTCTime !NominalDiffTime + deriving (Eq, Show, Generic) + +instance ToJSON ProcessStatus where + toJSON StatusRunning = object ["status" .= ("running" :: Text)] + toJSON (StatusFinished code time duration) = + let codeInt = case code of + ExitSuccess -> 0 :: Int + ExitFailure n -> n + in object + [ "status" .= ("finished" :: Text) + , "exit_code" .= codeInt + , "finished_at" .= time + , "duration_seconds" .= (realToFrac duration :: Double) + ] + toJSON (StatusKilled time duration) = + object + [ "status" .= ("killed" :: Text) + , "killed_at" .= time + , "duration_seconds" .= (realToFrac duration :: Double) + ] + +-- | Tracked handle and log buffers for a process. +data ManagedProcess = ManagedProcess + { procId :: !Text + , procCommand :: !Text + , procCwd :: !(Maybe FilePath) + , procStartTime :: !UTCTime + , procStatusVar :: !(TVar ProcessStatus) + , procOutputVar :: !(TVar [Text]) + , procHandle :: !ProcessHandle + , procWaiter :: !(Async (ExitCode, NominalDiffTime)) + } + +-- | In-memory registry for active and past background processes. +data ProcessManager = ProcessManager + { pmProcesses :: !(TVar (Map.Map Text ManagedProcess)) + , pmNextId :: !(TVar Int) + } + +-- | Initialize a new process manager instance. +newProcessManager :: IO ProcessManager +newProcessManager = do + procsVar <- newTVarIO Map.empty + idVar <- newTVarIO 1 + pure $ ProcessManager procsVar idVar + +-- | Extract an optional JSON field with a fallback default. +optField :: FromJSON a => Key -> a -> Object -> a +optField k def o = case parseEither (.:? k) o of + Right (Just v) -> v + _ -> def + +-- | Extract an optional JSON field as Maybe. +mbField :: FromJSON a => Key -> Object -> Maybe a +mbField k o = case parseEither (.:? k) o of + Right mv -> mv + _ -> Nothing + +-- | Format elapsed seconds into human-readable text. +formatDuration :: NominalDiffTime -> Text +formatDuration dt = + let secs = (fromRational (toRational dt) :: Double) + in T.pack (take 5 (show secs)) <> "s" + +-- | Truncate lines if total lines or byte count exceeds limits. +truncateOutput :: Int -> [Text] -> (Text, Bool) +truncateOutput maxLines linesList = + let total = length linesList + truncated = total > maxLines + selected = if truncated then drop (total - maxLines) linesList else linesList + body = T.unlines selected + in (body, truncated) + +-- ============================================================================ +-- 1. Command Run Tool +-- ============================================================================ + +-- | Command run tool with synchronous wait, backgrounding, and security safety checks. +commandRunTool :: + MonadIO m => + ProcessManager -> + SecurityPolicy -> + Tool m +commandRunTool pm policy = + withSecurity TierExecution policy $ + createTool + "command_run" + "Execute a shell command. Waits synchronously up to 'timeout_ms' (default: 5000ms). If the command is long-running, automatically transitions to a background process that can be monitored with 'command_status' or stopped with 'command_kill'." + ( object + [ "type" .= ("object" :: Text) + , "properties" + .= object + [ "command" + .= object + [ "type" .= ("string" :: Text) + , "description" .= ("Shell command line to execute" :: Text) + ] + , "cwd" + .= object + [ "type" .= ("string" :: Text) + , "description" .= ("Optional working directory for the command" :: Text) + ] + , "timeout_ms" + .= object + [ "type" .= ("integer" :: Text) + , "description" .= ("Milliseconds to wait synchronously before backgrounding (default: 5000)" :: Text) + ] + ] + , "required" .= (["command"] :: [Text]) + ] + ) + ( \case + Object o -> do + let rawCmd = optField "command" "" o :: Text + mbCwd = mbField "cwd" o :: Maybe FilePath + timeoutMs = optField "timeout_ms" 5000 o :: Int + + if T.null rawCmd + then pure $ Left $ toolError "Missing 'command' parameter." (Just "command_run") Nothing + else case validateCommandSafety policy rawCmd of + Left err -> pure $ Left err + Right () -> do + eProc <- liftIO $ spawnCommand pm rawCmd mbCwd + case eProc of + Left err -> + pure $ + Left $ + toolError + ("Failed to launch process: " <> T.pack (show (err :: SomeException))) + (Just "command_run") + Nothing + Right mp@ManagedProcess {..} -> do + -- Wait synchronously up to timeoutMs + let waitMicros = timeoutMs * 1000 + mDone <- liftIO $ timeout waitMicros (waitForCompletion mp) + case mDone of + Just () -> do + -- Process finished within timeoutMs + status <- liftIO $ readTVarIO procStatusVar + logs <- liftIO $ readTVarIO procOutputVar + let (outTxt, wasTruncated) = truncateOutput 100 logs + case status of + StatusFinished exitCode _ duration -> + let header = + "Command completed in " + <> formatDuration duration + <> " with " + <> ( case exitCode of + ExitSuccess -> "exit code 0 (Success)" + ExitFailure code -> "exit code " <> T.pack (show code) <> " (Failure)" + ) + <> ":" + <> (if wasTruncated then " [showing last 100 lines]" else "") + in pure $ Right $ header <> "\n" <> outTxt + StatusKilled _ duration -> + pure $ Right $ "Command was terminated after " <> formatDuration duration <> "." + StatusRunning -> + pure $ Right $ "Command is running (ID: [" <> procId <> "])." + Nothing -> do + -- Still running: background notification + now <- liftIO getCurrentTime + let elapsed = diffUTCTime now procStartTime + pure $ + Right $ + "Command is still running in background (process_id: \"" + <> procId + <> "\"). Elapsed: " + <> formatDuration elapsed + <> ".\nUse 'command_status' with process_id=\"" + <> procId + <> "\" to inspect output logs, or 'command_kill' to terminate." + _ -> pure $ Left $ toolError "Invalid arguments object" (Just "command_run") Nothing + ) + where + spawnCommand :: ProcessManager -> Text -> Maybe FilePath -> IO (Either SomeException ManagedProcess) + spawnCommand ProcessManager {..} cmd mbCwd = try $ do + now <- getCurrentTime + pId <- atomically $ do + curId <- readTVar pmNextId + writeTVar pmNextId (curId + 1) + pure $ "proc-" <> T.pack (show curId) + + statusVar <- newTVarIO StatusRunning + outputVar <- newTVarIO [] + + let cp = + (shell (T.unpack cmd)) + { cwd = mbCwd + , std_out = CreatePipe + , std_err = CreatePipe + } + + (Nothing, Just hOut, Just hErr, ph) <- createProcess cp + + -- Spawn async readers for stdout and stderr + outAsync <- async $ readStreamLines hOut outputVar + errAsync <- async $ readStreamLines hErr outputVar + + -- Spawn async waiter thread that waits for process and stream drainage + waiterAsync <- async $ do + exitCode <- waitForProcess ph + _ <- wait outAsync + _ <- wait errAsync + end <- getCurrentTime + let dur = diffUTCTime end now + atomically $ writeTVar statusVar (StatusFinished exitCode end dur) + pure (exitCode, dur) + + let mp = + ManagedProcess + { procId = pId + , procCommand = cmd + , procCwd = mbCwd + , procStartTime = now + , procStatusVar = statusVar + , procOutputVar = outputVar + , procHandle = ph + , procWaiter = waiterAsync + } + + atomically $ modifyTVar' pmProcesses (Map.insert pId mp) + pure mp + + readStreamLines hnd var = loop + where + loop = do + eLine <- try (hGetLine hnd) + case eLine of + Left (_ :: SomeException) -> pure () + Right l -> do + atomically $ modifyTVar' var (\acc -> acc ++ [T.pack l]) + loop + + waitForCompletion ManagedProcess {..} = do + _ <- wait procWaiter + pure () + +-- ============================================================================ +-- 2. Command Status Tool +-- ============================================================================ + +-- | Inspect status, runtime, and output logs of a running or completed process. +commandStatusTool :: + MonadIO m => + ProcessManager -> + SecurityPolicy -> + Tool m +commandStatusTool ProcessManager {..} policy = + withSecurity TierReadOnly policy $ + createTool + "command_status" + "Inspect the execution status, runtime duration, and latest output logs for a background process." + ( object + [ "type" .= ("object" :: Text) + , "properties" + .= object + [ "process_id" + .= object + [ "type" .= ("string" :: Text) + , "description" .= ("ID of the process to inspect (e.g. 'proc-1')" :: Text) + ] + , "tail_lines" + .= object + [ "type" .= ("integer" :: Text) + , "description" .= ("Number of latest output lines to view (default: 50)" :: Text) + ] + ] + , "required" .= (["process_id"] :: [Text]) + ] + ) + ( \case + Object o -> do + let pId = optField "process_id" "" o :: Text + tailLines = optField "tail_lines" 50 o :: Int + + if T.null pId + then pure $ Left $ toolError "Missing 'process_id' parameter." (Just "command_status") Nothing + else do + procs <- liftIO $ readTVarIO pmProcesses + case Map.lookup pId procs of + Nothing -> + pure $ + Left $ + toolError + ("Process '" <> pId <> "' not found in active process registry.") + (Just "command_status") + Nothing + Just ManagedProcess {..} -> do + now <- liftIO getCurrentTime + status <- liftIO $ readTVarIO procStatusVar + logs <- liftIO $ readTVarIO procOutputVar + let totalLines = length logs + (outTxt, wasTruncated) = truncateOutput tailLines logs + statusDesc = case status of + StatusRunning -> + "Status: Running (elapsed: " <> formatDuration (diffUTCTime now procStartTime) <> ")" + StatusFinished exitCode _ duration -> + "Status: Finished in " + <> formatDuration duration + <> " with " + <> ( case exitCode of + ExitSuccess -> "exit code 0 (Success)" + ExitFailure code -> "exit code " <> T.pack (show code) + ) + StatusKilled _ duration -> + "Status: Terminated after " <> formatDuration duration + + header = + "=== Process [" + <> procId + <> "] ===\nCommand: " + <> procCommand + <> "\n" + <> statusDesc + <> "\nOutput (" + <> T.pack (show totalLines) + <> " lines" + <> (if wasTruncated then ", showing last " <> T.pack (show tailLines) else "") + <> "):\n" + pure $ Right $ header <> outTxt + _ -> pure $ Left $ toolError "Invalid arguments object" (Just "command_status") Nothing + ) + +-- ============================================================================ +-- 3. Command Kill Tool +-- ============================================================================ + +-- | Cleanly terminate a background process. +commandKillTool :: + MonadIO m => + ProcessManager -> + SecurityPolicy -> + Tool m +commandKillTool ProcessManager {..} policy = + withSecurity TierExecution policy $ + createTool + "command_kill" + "Terminate a running background process." + ( object + [ "type" .= ("object" :: Text) + , "properties" + .= object + [ "process_id" + .= object + [ "type" .= ("string" :: Text) + , "description" .= ("ID of the process to terminate (e.g. 'proc-1')" :: Text) + ] + ] + , "required" .= (["process_id"] :: [Text]) + ] + ) + ( \case + Object o -> do + let pId = optField "process_id" "" o :: Text + if T.null pId + then pure $ Left $ toolError "Missing 'process_id' parameter." (Just "command_kill") Nothing + else do + procs <- liftIO $ readTVarIO pmProcesses + case Map.lookup pId procs of + Nothing -> + pure $ + Left $ + toolError + ("Process '" <> pId <> "' not found.") + (Just "command_kill") + Nothing + Just ManagedProcess {..} -> do + now <- liftIO getCurrentTime + liftIO $ terminateProcess procHandle + liftIO $ cancel procWaiter + let dur = diffUTCTime now procStartTime + liftIO $ atomically $ writeTVar procStatusVar (StatusKilled now dur) + pure $ Right $ "Successfully terminated process [" <> pId <> "]." + _ -> pure $ Left $ toolError "Invalid arguments object" (Just "command_kill") Nothing + ) + +-- ============================================================================ +-- Complete Process Suite Factory +-- ============================================================================ + +-- | Create the complete command execution and process control tool suite. +newProcessSuite :: + MonadIO m => + SecurityPolicy -> + IO [Tool m] +newProcessSuite policy = do + pm <- newProcessManager + pure + [ commandRunTool pm policy + , commandStatusTool pm policy + , commandKillTool pm policy + ] diff --git a/src/Langchain/Tool/Security.hs b/src/Langchain/Tool/Security.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Tool/Security.hs @@ -0,0 +1,304 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Langchain.Tool.Security +Description : Security, permission tiers, sandbox validation, and HITL hooks +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Provides tiered permission policies for tools (ReadOnly, WorkspaceWrite, Execution, Admin), +filesystem path sandboxing, sensitive credential filtering, dangerous command prevention, +and Human-in-the-Loop (HITL) approval hooks. +-} +module Langchain.Tool.Security + ( -- * Permission Tiers + ToolTier (..) + + -- * Security Policy + , SecurityPolicy (..) + , defaultSecurityPolicy + , readOnlySecurityPolicy + , workspaceSandboxPolicy + , unrestrictedSecurityPolicy + + -- * Approval & HITL + , ApprovalRequest (..) + , ApprovalDecision (..) + + -- * Validation Functions + , checkTierPermission + , validateSandboxPath + , isSensitivePath + , validateCommandSafety + + -- * Tool Security Combinator + , withSecurity + ) where + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (FromJSON, ToJSON, Value) +import Data.Char (toLower) +import Data.List (isInfixOf, isPrefixOf) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) +import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist) +import System.FilePath (isAbsolute, normalise, pathSeparator, takeDirectory, takeFileName, ()) + +import Langchain.Error (LangchainError, toolError) +import Langchain.Tool (Tool (..)) + +-- | Tier levels representing the risk and side-effects of tool execution. +data ToolTier + = -- | Safe, observational queries (find, grep, read, list, status) + TierReadOnly + | -- | Modifies files within workspace sandbox (write, edit, rollback) + TierWorkspaceWrite + | -- | Spawns system processes and shell commands + TierExecution + | -- | Unrestricted or system-level modifications + TierAdmin + deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, ToJSON, FromJSON) + +-- | Human-in-the-Loop approval request structure. +data ApprovalRequest = ApprovalRequest + { reqToolName :: !Text + , reqTier :: !ToolTier + , reqArguments :: !Value + , reqDescription :: !Text + } + deriving (Eq, Show, Generic, ToJSON, FromJSON) + +-- | Decision result from an approval hook. +data ApprovalDecision + = Approved + | Denied !Text + deriving (Eq, Show, Generic, ToJSON, FromJSON) + +-- | Security policy controlling tool authorization and sandboxing bounds. +data SecurityPolicy = SecurityPolicy + { policyAllowedTiers :: !(Set.Set ToolTier) + -- ^ Set of authorized tiers + , policyWorkspaceRoot :: !(Maybe FilePath) + -- ^ If set, restricts file operations to within this directory tree + , policySensitivePatterns :: ![Text] + -- ^ File names or substrings blocked from reading/writing (e.g. .env, id_rsa, keys) + , policyCommandWhitelist :: !(Maybe [Text]) + -- ^ Optional strict whitelist of allowed command binaries + , policyCommandBlacklist :: ![Text] + -- ^ Blocked dangerous command substrings (e.g. rm -rf /, fork bombs) + , policyApprovalHook :: !(Maybe (ApprovalRequest -> IO ApprovalDecision)) + -- ^ Optional Human-in-the-Loop approval callback for sensitive actions + } + deriving (Generic) + +{- | Default standard security policy: + +* Allows 'TierReadOnly', 'TierWorkspaceWrite', and 'TierExecution'. +* Protects sensitive secret files (.env, private keys, credential files). +* Blocks destructive shell command patterns. +-} +defaultSecurityPolicy :: SecurityPolicy +defaultSecurityPolicy = + SecurityPolicy + { policyAllowedTiers = Set.fromList [TierReadOnly, TierWorkspaceWrite, TierExecution] + , policyWorkspaceRoot = Nothing + , policySensitivePatterns = + [ ".env" + , "id_rsa" + , "id_ed25519" + , "id_ecdsa" + , ".aws/credentials" + , ".gemini_api_key" + , "shadow" + , "master.passwd" + ] + , policyCommandWhitelist = Nothing + , policyCommandBlacklist = + [ "rm -rf /" + , "rm -fr /" + , ":(){ :|:& };:" + , "mkfs" + , "dd if=/dev/zero" + , "chmod -R 777 /" + , "chown -R" + , "> /dev/sda" + ] + , policyApprovalHook = Nothing + } + +-- | Restrictive read-only security policy (prevents any state mutations). +readOnlySecurityPolicy :: SecurityPolicy +readOnlySecurityPolicy = + defaultSecurityPolicy + { policyAllowedTiers = Set.singleton TierReadOnly + } + +-- | Sandbox security policy restricting operations strictly to a workspace directory. +workspaceSandboxPolicy :: FilePath -> SecurityPolicy +workspaceSandboxPolicy root = + defaultSecurityPolicy + { policyWorkspaceRoot = Just root + } + +-- | Unrestricted security policy allowing all tiers and bypassing sensitive file filters. +unrestrictedSecurityPolicy :: SecurityPolicy +unrestrictedSecurityPolicy = + SecurityPolicy + { policyAllowedTiers = Set.fromList [TierReadOnly, TierWorkspaceWrite, TierExecution, TierAdmin] + , policyWorkspaceRoot = Nothing + , policySensitivePatterns = [] + , policyCommandWhitelist = Nothing + , policyCommandBlacklist = [] + , policyApprovalHook = Nothing + } + +-- | Check whether a tool tier is permitted under the policy. +checkTierPermission :: SecurityPolicy -> ToolTier -> Either LangchainError () +checkTierPermission SecurityPolicy {..} tier + | tier `Set.member` policyAllowedTiers = Right () + | otherwise = + Left $ + toolError + ( "Permission denied: Tool requires " + <> T.pack (show tier) + <> " authorization, which is not granted by the current security policy." + ) + Nothing + Nothing + +-- | Check if a path refers to a sensitive file (keys, credentials, secrets). +isSensitivePath :: SecurityPolicy -> FilePath -> Bool +isSensitivePath SecurityPolicy {..} path = + let lowerPath = map toLower (normalise path) + in any (\pat -> T.unpack (T.toLower pat) `isInfixOf` lowerPath) policySensitivePatterns + +-- | Validate that a file path remains safely within the configured workspace sandbox. +validateSandboxPath :: + MonadIO m => + SecurityPolicy -> + FilePath -> + m (Either LangchainError FilePath) +validateSandboxPath SecurityPolicy {..} rawPath = liftIO $ do + -- 1. Check sensitive path filter + if isSensitivePath + ( SecurityPolicy + policyAllowedTiers + policyWorkspaceRoot + policySensitivePatterns + policyCommandWhitelist + policyCommandBlacklist + policyApprovalHook + ) + rawPath + then + pure $ + Left $ + toolError + ("Access denied: Path matches sensitive/secret file policy: " <> T.pack rawPath) + Nothing + Nothing + else case policyWorkspaceRoot of + Nothing -> pure $ Right (normalise rawPath) + Just root -> do + canonRoot <- canonicalizePath root + let targetPath = + if isAbsolute rawPath + then rawPath + else canonRoot rawPath + canonTarget <- canonicalizeAncestor targetPath + let prefix = canonRoot ++ [pathSeparator] + isInside = canonTarget == canonRoot || prefix `isPrefixOf` canonTarget + if isInside + then pure $ Right canonTarget + else + pure $ + Left $ + toolError + ( "Sandbox violation: Path '" + <> T.pack rawPath + <> "' escapes the workspace root '" + <> T.pack canonRoot + <> "'." + ) + Nothing + Nothing + where + canonicalizeAncestor :: FilePath -> IO FilePath + canonicalizeAncestor p = do + ex <- doesFileExist p + dx <- doesDirectoryExist p + if ex || dx + then canonicalizePath p + else do + let parent = takeDirectory p + if parent == p + then canonicalizePath p + else do + canonParent <- canonicalizeAncestor parent + pure (canonParent takeFileName p) + +-- | Validate that a shell command does not contain dangerous destructive patterns. +validateCommandSafety :: SecurityPolicy -> Text -> Either LangchainError () +validateCommandSafety SecurityPolicy {..} cmd = do + -- Check blacklist + let lowerCmd = T.toLower cmd + mapM_ + ( \bl -> + if bl `T.isInfixOf` lowerCmd + then + Left $ + toolError + ("Command blocked by security policy (prohibited pattern: '" <> bl <> "')") + Nothing + Nothing + else Right () + ) + policyCommandBlacklist + + -- Check whitelist if present + case policyCommandWhitelist of + Nothing -> Right () + Just wl -> + let firstWord = case T.words cmd of + (w : _) -> w + [] -> "" + in if firstWord `elem` wl + then Right () + else + Left $ + toolError + ("Command '" <> firstWord <> "' is not in the authorized command whitelist.") + Nothing + Nothing + +-- | Wrap a 'Tool m' with permission tier enforcement, sandboxing, and optional HITL approval. +withSecurity :: + MonadIO m => + ToolTier -> + SecurityPolicy -> + Tool m -> + Tool m +withSecurity tier policy tool@Tool {..} = + tool + { toolExecute = \args -> do + case checkTierPermission policy tier of + Left err -> pure $ Left err + Right () -> do + -- Check HITL approval if hook is defined + mApproval <- case policyApprovalHook policy of + Nothing -> pure Approved + Just hook -> liftIO $ hook (ApprovalRequest toolName tier args toolDescription) + case mApproval of + Denied reason -> + pure $ + Left $ + toolError ("Execution rejected by approval policy: " <> reason) (Just toolName) Nothing + Approved -> toolExecute args + } diff --git a/src/Langchain/Tool/Shell.hs b/src/Langchain/Tool/Shell.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Tool/Shell.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Langchain.Tool.Shell +Description : Shell command execution tool with safety and security policy enforcement +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Provides shell command execution capabilities for agents via System.Process +with safety verification and permission checks. +-} +module Langchain.Tool.Shell + ( shellTool + , secureShellTool + ) where + +import Control.Exception (SomeException, try) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (Value (..), object, (.=)) +import Data.Aeson.Types (parseEither, (.:?)) +import Data.Text (Text) +import qualified Data.Text as T +import System.Exit (ExitCode (..)) +import System.Process (readProcessWithExitCode) + +import Langchain.Error (toolError) +import Langchain.Tool (Tool (..), createTool) +import Langchain.Tool.Security + ( SecurityPolicy + , ToolTier (..) + , defaultSecurityPolicy + , validateCommandSafety + , withSecurity + ) + +-- | Tool that executes a shell command with default security policy. +shellTool :: MonadIO m => Tool m +shellTool = secureShellTool defaultSecurityPolicy + +-- | Tool that executes a shell command under a specific 'SecurityPolicy'. +secureShellTool :: MonadIO m => SecurityPolicy -> Tool m +secureShellTool policy = + withSecurity TierExecution policy $ + createTool + "shell_command" + "Execute a shell command line (e.g. bash/sh) and return stdout and stderr output." + ( object + [ "type" .= ("object" :: Text) + , "properties" + .= object + [ "command" + .= object + [ "type" .= ("string" :: Text) + , "description" .= ("The shell command line to execute" :: Text) + ] + ] + , "required" .= (["command"] :: [Text]) + ] + ) + ( \case + Object o -> case parseEither (.:? "command") o of + Right (Just cmd) -> case validateCommandSafety policy cmd of + Left err -> pure $ Left err + Right () -> do + eRes <- liftIO $ try (readProcessWithExitCode "sh" ["-c", T.unpack cmd] "") + case eRes of + Left err -> + pure $ Left $ toolError (T.pack $ show (err :: SomeException)) (Just "shell_command") Nothing + Right (ExitSuccess, stdoutStr, stderrStr) -> + let out = T.strip (T.pack stdoutStr) + err = T.strip (T.pack stderrStr) + in if T.null out + then if T.null err then pure $ Right "Command completed with no output." else pure $ Right err + else pure $ Right out + Right (ExitFailure code, stdoutStr, stderrStr) -> + let combined = T.strip (T.pack (stdoutStr <> "\n" <> stderrStr)) + in pure $ + Right $ + "Command exited with code " + <> T.pack (show code) + <> (if T.null combined then "" else ": " <> combined) + _ -> pure $ Left $ toolError "Missing 'command' parameter" (Just "shell_command") Nothing + _ -> pure $ Left $ toolError "Invalid arguments object" (Just "shell_command") Nothing + ) diff --git a/src/Langchain/VectorStore.hs b/src/Langchain/VectorStore.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/VectorStore.hs @@ -0,0 +1,15 @@ +{- | +Module : Langchain.VectorStore +Description : Vector store abstraction and implementations +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental +-} +module Langchain.VectorStore + ( module Langchain.VectorStore.Core + , module Langchain.VectorStore.InMemory + ) where + +import Langchain.VectorStore.Core +import Langchain.VectorStore.InMemory diff --git a/src/Langchain/VectorStore/Core.hs b/src/Langchain/VectorStore/Core.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/VectorStore/Core.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE FlexibleContexts #-} + +{- | +Module : Langchain.VectorStore.Core +Description : Effect-polymorphic vector store abstraction for semantic search +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +Effect-polymorphic VectorStore typeclass supporting document insertion, +deletion, and vector/text similarity search. +-} +module Langchain.VectorStore.Core + ( VectorStore (..) + ) where + +import Control.Monad.Except (MonadError) +import Control.Monad.IO.Class (MonadIO) +import Data.Int (Int64) +import Data.Text (Text) + +import Langchain.DocumentLoader.Core (Document) +import Langchain.Error (LangchainError) + +-- | Effect-polymorphic VectorStore typeclass +class VectorStore vs where + -- | Add documents with generated embeddings + addDocuments :: + (MonadIO m, MonadError LangchainError m) => + vs -> + [Document] -> + m vs + + -- | Delete documents by unique integer ID + delete :: + (MonadIO m, MonadError LangchainError m) => + vs -> + [Int64] -> + m vs + + -- | Semantic similarity search using text query + similaritySearch :: + (MonadIO m, MonadError LangchainError m) => + vs -> + Text -> + Int -> + m [Document] + + -- | Direct similarity search using embedding vector + similaritySearchByVector :: + (MonadIO m, MonadError LangchainError m) => + vs -> + [Float] -> + Int -> + m [Document] diff --git a/src/Langchain/VectorStore/InMemory.hs b/src/Langchain/VectorStore/InMemory.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/VectorStore/InMemory.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE FlexibleContexts #-} + +{- | +Module : Langchain.VectorStore.InMemory +Description : In-memory vector store implementation for LangChain Haskell +Copyright : (c) 2025-2026 Tushar Adhatrao +License : MIT +Maintainer : Tushar Adhatrao +Stability : experimental + +In-memory vector store implementation supporting cosine similarity search. +-} +module Langchain.VectorStore.InMemory + ( InMemory (..) + , fromDocuments + , emptyInMemoryVectorStore + , norm + , dotProduct + , cosineSimilarity + ) where + +import Control.Monad.Except (MonadError) +import Control.Monad.IO.Class (MonadIO) +import Data.Bifunctor (second) +import Data.Int (Int64) +import Data.List (sortBy) +import qualified Data.Map.Strict as Map +import Data.Ord (comparing) + +import Langchain.DocumentLoader.Core (Document) +import Langchain.Embeddings.Core +import Langchain.Error (LangchainError) +import Langchain.VectorStore.Core + +-- | Compute dot product of two vectors +dotProduct :: [Float] -> [Float] -> Float +dotProduct a b = sum $ zipWith (*) a b + +-- | Calculate Euclidean norm of a vector +norm :: [Float] -> Float +norm a = sqrt $ sum $ map (^ (2 :: Int)) a + +-- | Calculate cosine similarity between vectors +cosineSimilarity :: [Float] -> [Float] -> Float +cosineSimilarity a b = + let nA = norm a + nB = norm b + in if nA == 0 || nB == 0 + then 0 + else dotProduct a b / (nA * nB) + +-- | In-memory vector store data type +data InMemory m = InMemory + { embeddingModel :: m + , store :: Map.Map Int64 (Document, [Float]) + } + deriving (Show, Eq) + +-- | Create empty in-memory store with embedding model +emptyInMemoryVectorStore :: m -> InMemory m +emptyInMemoryVectorStore model = InMemory model Map.empty + +-- | Initialize store from documents using embeddings +fromDocuments :: + (Embeddings m, MonadIO monad, MonadError LangchainError monad) => + m -> + [Document] -> + monad (InMemory m) +fromDocuments model docs = do + let vs = emptyInMemoryVectorStore model + addDocuments vs docs + +instance Embeddings m => VectorStore (InMemory m) where + addDocuments inMem docs = do + floats <- embedDocuments (embeddingModel inMem) docs + let currStore = store inMem + mbMaxKey = Map.lookupMax currStore + startIdx = maybe 1 (\(k, _) -> k + 1) mbMaxKey + newEntries = Map.fromList $ zip [startIdx ..] (zip docs floats) + newInMem = inMem {store = Map.union newEntries currStore} + pure newInMem + + delete inMem ids = do + let currStore = store inMem + newStore = foldl (flip Map.delete) currStore ids + pure inMem {store = newStore} + + similaritySearch vs query k = do + queryVec <- embedQuery (embeddingModel vs) query + similaritySearchByVector vs queryVec k + + similaritySearchByVector vs queryVec k = do + let similarities = + map + (second (cosineSimilarity queryVec) . snd) + (Map.toList $ store vs) + sorted = sortBy (comparing (negate . snd)) similarities + topK = take k sorted + pure $ map fst topK diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,11 +2,16 @@ import Test.Tasty -import qualified Test.Langchain.Core.Model as ModelTest -import qualified Test.Langchain.Core.Monad as MonadTest -import qualified Test.Langchain.Core.Runnable as RunnableTest -import qualified Test.Langchain.Core.Stream as StreamTest -import qualified Test.Langchain.Core.Tool as ToolTest +import qualified Test.Langchain.Callback as CallbackTest +import qualified Test.Langchain.Model as ModelTest +import qualified Test.Langchain.Monad as MonadTest +import qualified Test.Langchain.Observability as ObservabilityTest +import qualified Test.Langchain.PromptTemplate as PromptTemplateTest +import qualified Test.Langchain.Resilience as ResilienceTest +import qualified Test.Langchain.Retriever as RetrieverTest +import qualified Test.Langchain.Runnable as RunnableTest +import qualified Test.Langchain.Stream as StreamTest +import qualified Test.Langchain.Tool as ToolTest main :: IO () main = defaultMain tests @@ -20,4 +25,9 @@ , StreamTest.tests , ToolTest.tests , MonadTest.tests + , PromptTemplateTest.tests + , ObservabilityTest.tests + , CallbackTest.tests + , RetrieverTest.tests + , ResilienceTest.tests ] diff --git a/test/Test/Langchain/Callback.hs b/test/Test/Langchain/Callback.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Callback.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Callback (tests) where + +import Control.Concurrent.STM (readTVarIO) +import Data.Time.Clock (getCurrentTime) +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Callback + +tests :: TestTree +tests = + testGroup + "Langchain.Callback" + [ testCase "CallbackManager registers handler and dispatches events" $ do + mgr <- newCallbackManager + (handler, logsVar) <- newLoggingCallbackHandler "TestHandler" + registerHandler mgr handler + + now <- getCurrentTime + dispatchEvent mgr (OnLLMStart "qwen2.5:7b" ["Hello"] now) + dispatchEvent mgr (OnLLMEnd "qwen2.5:7b" "Hi there!" 1500 now) + + logged <- readTVarIO logsVar + length logged @?= 2 + ] diff --git a/test/Test/Langchain/Core/Model.hs b/test/Test/Langchain/Core/Model.hs deleted file mode 100644 --- a/test/Test/Langchain/Core/Model.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Langchain.Core.Model (tests) where - -import Test.Tasty -import Test.Tasty.HUnit - -import Control.Monad.Except (runExceptT) -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.Map.Strict as Map - -import Langchain.Core.Model -import Test.Langchain.Core.TestModel (TestChatModel (..)) - -tests :: TestTree -tests = - testGroup - "Langchain.Core.Model" - [ testGroup - "Multi-Modal ContentBlock & Message" - [ testCase "textMessage creates User message with TextBlock" $ do - let msg = userMessage "Hello AI" - messageRole msg @?= User - extractMessageText msg @?= "Hello AI" - messageMetadata msg @?= Map.empty - , testCase "systemMessage creates System message" $ do - let msg = systemMessage "You are a assistant" - messageRole msg @?= System - extractMessageText msg @?= "You are a assistant" - , testCase "imageMessage creates ImageBlock message" $ do - let msg = imageMessage User "image/png" "base64data==" - messageRole msg @?= User - case messageContents msg of - (ImageBlock (ImageContent (ImageBase64 (Just mime) b64) Nothing Nothing) :| []) -> do - mime @?= "image/png" - b64 @?= "base64data==" - _ -> assertFailure "Expected ImageBlock" - ] - , testGroup - "Effect-Polymorphic ChatModel" - [ testCase "invoke returns Assistant response" $ do - let model = TestChatModel "Hello human" "mock-gpt" - input = [userMessage "Hi"] - res <- runExceptT $ invoke model input Nothing - case res of - Left err -> assertFailure $ "Unexpected error: " ++ show err - Right msg -> do - messageRole msg @?= Assistant - extractMessageText msg @?= "Hello human" - , testCase "batch processes multiple inputs sequentially" $ do - let model = TestChatModel "Pong" "mock-gpt" - inputs = [[userMessage "Ping 1"], [userMessage "Ping 2"]] - res <- runExceptT $ batch model inputs Nothing - case res of - Left err -> assertFailure $ "Unexpected error: " ++ show err - Right msgs -> do - length msgs @?= 2 - map extractMessageText msgs @?= ["Pong", "Pong"] - ] - ] diff --git a/test/Test/Langchain/Core/Monad.hs b/test/Test/Langchain/Core/Monad.hs deleted file mode 100644 --- a/test/Test/Langchain/Core/Monad.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Langchain.Core.Monad (tests) where - -import Control.Monad.Reader (ask) -import Test.Tasty -import Test.Tasty.HUnit - -import Langchain.Core.Error (internalError) -import Langchain.Core.Monad - -tests :: TestTree -tests = - testGroup - "Test.Langchain.Core.Monad" - [ testCase "runLangchainT executes pure computations successfully" $ do - res <- runLangchainT () (pure ("hello" :: String)) - res @?= Right "hello" - , testCase "runLangchainT propagates errors via throwLangchainError" $ do - res <- runLangchainT () $ do - throwLangchainError (internalError "test fail" Nothing Nothing) - case res of - Left _ -> pure () - Right _ -> assertFailure "Expected error" - , testCase "runLangchainT threads custom env through ask" $ do - -- Developers use ask / asks from mtl directly with their own r - let customEnv = (42 :: Int) - res <- runLangchainT customEnv ask - res @?= Right 42 - ] diff --git a/test/Test/Langchain/Core/Runnable.hs b/test/Test/Langchain/Core/Runnable.hs deleted file mode 100644 --- a/test/Test/Langchain/Core/Runnable.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Test.Langchain.Core.Runnable (tests) where - -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck as QC - -import Control.Monad.Except (ExceptT, runExceptT) -import qualified Data.Text as T - -import Langchain.Core.Error -import Langchain.Core.Runnable - -type TestMonad = ExceptT LangchainError IO - --- Pure test lambda helpers -addOneLambda :: RunnableTree TestMonad Int Int -addOneLambda = runLambda $ \x -> pure (Right (x + 1)) - -doubleLambda :: RunnableTree TestMonad Int Int -doubleLambda = runLambda $ \x -> pure (Right (x * 2)) - -failLambda :: RunnableTree TestMonad Int Int -failLambda = runLambda $ \_ -> pure (Left $ runnableError "Pipeline failed" Nothing Nothing) - -tests :: TestTree -tests = - testGroup - "Langchain.Core.Runnable" - [ testGroup - "Identity Laws" - [ testCase "Left Identity: Id |>> t == t" $ do - let t = addOneLambda - r1 <- runExceptT $ interpret (Id |>> t) 5 - r2 <- runExceptT $ interpret t 5 - r1 @?= Right 6 - r1 @?= r2 - , testCase "Right Identity: t |>> Id == t" $ do - let t = addOneLambda - r1 <- runExceptT $ interpret (t |>> Id) 5 - r2 <- runExceptT $ interpret t 5 - r1 @?= Right 6 - r1 @?= r2 - ] - , testGroup - "Sequential Composition Laws" - [ testCase "Seq executes in left-to-right order" $ do - let pipeline = addOneLambda |>> doubleLambda -- (5 + 1) * 2 = 12 - res <- runExceptT $ interpret pipeline 5 - res @?= Right 12 - , testCase "Seq propagates errors early" $ do - let pipeline = failLambda |>> doubleLambda - res <- runExceptT $ interpret pipeline 5 - case res of - Left (RunnableError msg _) -> assertBool "Should contain error message" ("failed" `T.isInfixOf` msg) - _ -> assertFailure "Expected RunnableError" - ] - , testGroup - "Parallel Composition Laws (&>&)" - [ testCase "Par executes branches concurrently" $ do - let pipeline = addOneLambda &>& doubleLambda - res <- runExceptT $ interpret pipeline 10 - res @?= Right (11, 20) - ] - , testGroup - "Branching and Fallback" - [ testCase "Branch selects True branch" $ do - let pipeline = Branch (\x -> pure (x > 0)) addOneLambda doubleLambda - res <- runExceptT $ interpret pipeline 5 - res @?= Right 6 - , testCase "Branch selects False branch" $ do - let pipeline = Branch (\x -> pure (x > 0)) addOneLambda doubleLambda - res <- runExceptT $ interpret pipeline (-5) - res @?= Right (-10) - , testCase "Fallback executes secondary when primary fails" $ do - let pipeline = Fallback failLambda doubleLambda - res <- runExceptT $ interpret pipeline 7 - res @?= Right 14 - ] - , testGroup - "Property Tests (QuickCheck)" - [ QC.testProperty "Identity Law: Id |>> t(x) == t(x)" $ \(x :: Int) -> - QC.ioProperty $ do - r1 <- runExceptT $ interpret (Id |>> addOneLambda) x - r2 <- runExceptT $ interpret addOneLambda x - pure (r1 == r2) - , QC.testProperty "Associativity: (f |>> g) |>> h == f |>> (g |>> h)" $ \(x :: Int) -> - QC.ioProperty $ do - let f = addOneLambda - g = doubleLambda - h = addOneLambda - p1 = (f |>> g) |>> h - p2 = f |>> (g |>> h) - r1 <- runExceptT $ interpret p1 x - r2 <- runExceptT $ interpret p2 x - pure (r1 == r2) - ] - ] diff --git a/test/Test/Langchain/Core/Stream.hs b/test/Test/Langchain/Core/Stream.hs deleted file mode 100644 --- a/test/Test/Langchain/Core/Stream.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Langchain.Core.Stream (tests) where - -import Test.Tasty -import Test.Tasty.HUnit - -import Control.Monad.Except (runExceptT) -import Control.Monad.Trans.Resource (runResourceT) - -import Langchain.Core.Model -import Langchain.Core.Stream -import Test.Langchain.Core.TestModel (TestChatModel (..)) - -tests :: TestTree -tests = - testGroup - "Langchain.Core.Stream" - [ testCase "stream emits LLMStart, LLMChunk, LLMEnd events" $ do - let model = TestChatModel "Streamed content" "mock-gpt" - input = [userMessage "Stream test"] - res <- runResourceT $ runExceptT $ collectEvents (stream model input Nothing) - case res of - Left err -> assertFailure $ "Unexpected stream error: " ++ show err - Right events -> do - length events @?= 3 - case events of - [s@LLMStart {}, c@LLMChunk {}, e@LLMEnd {}] -> do - modelName s @?= "mock-gpt" - chunkText c @?= "Streamed content" - extractMessageText (finalMessage e) @?= "Streamed content" - _ -> assertFailure $ "Unexpected event sequence: " ++ show events - ] diff --git a/test/Test/Langchain/Core/TestModel.hs b/test/Test/Langchain/Core/TestModel.hs deleted file mode 100644 --- a/test/Test/Langchain/Core/TestModel.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - -module Test.Langchain.Core.TestModel - ( TestChatModel (..) - ) where - -import Data.Conduit (yield) -import Data.Text (Text) - -import Langchain.Core.Model -import Langchain.Core.Stream (StreamEvent (..)) - -data TestChatModel = TestChatModel - { testResponse :: Text - , testModelName :: Text - } - deriving (Eq, Show) - -instance ChatModel TestChatModel where - type ModelConfig TestChatModel = () - - invoke model _ _ = pure $ assistantMessage (testResponse model) - - stream model inputMsgs _ = do - let rId = "test-run-id" - yield $ LLMStart rId (testModelName model) inputMsgs - yield $ LLMChunk rId (testResponse model) Nothing - yield $ LLMEnd rId (assistantMessage $ testResponse model) Nothing diff --git a/test/Test/Langchain/Core/Tool.hs b/test/Test/Langchain/Core/Tool.hs deleted file mode 100644 --- a/test/Test/Langchain/Core/Tool.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Test.Langchain.Core.Tool (tests) where - -import Data.Aeson -import Data.Aeson.Types (parseEither) -import Data.Text (Text) -import Langchain.Core.Error -import Langchain.Core.Tool -import Test.Tasty -import Test.Tasty.HUnit - -calcExec :: Value -> IO (Either LangchainError Text) -calcExec (Object _) = pure $ Right "42" -calcExec _ = pure $ Left $ toolError "Invalid arguments" (Just "calc") Nothing - -tests :: TestTree -tests = - testGroup - "Langchain.Core.Tool" - [ testCase "createTool initializes tool attributes" $ do - let t = createTool "calculator" "Performs math" (object []) calcExec - toolName t @?= "calculator" - toolDescription t @?= "Performs math" - , testCase "toolToValue generates correct JSON schema structure" $ do - let t = createTool "calculator" "Performs math" (object ["type" .= ("object" :: Text)]) calcExec - val = toolToValue t - case val of - Object o -> do - case parseEither (.: "type") o of - Right ("function" :: Text) -> pure () - res -> assertFailure $ "Expected type = function, got: " ++ show res - _ -> assertFailure "Expected JSON Object" - , testCase "toolExecute runs successfully on valid input" $ do - let t = createTool "calculator" "Performs math" (object []) calcExec - res <- toolExecute t (object []) - res @?= Right "42" - ] diff --git a/test/Test/Langchain/Model.hs b/test/Test/Langchain/Model.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Model.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Model (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Control.Monad.Except (runExceptT) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map.Strict as Map + +import Langchain.Model +import Test.Langchain.TestModel (TestChatModel (..)) + +tests :: TestTree +tests = + testGroup + "Langchain.Model" + [ testGroup + "Multi-Modal ContentBlock & Message" + [ testCase "textMessage creates User message with TextBlock" $ do + let msg = userMessage "Hello AI" + messageRole msg @?= User + extractMessageText msg @?= "Hello AI" + messageMetadata msg @?= Map.empty + , testCase "systemMessage creates System message" $ do + let msg = systemMessage "You are a assistant" + messageRole msg @?= System + extractMessageText msg @?= "You are a assistant" + , testCase "imageMessage creates ImageBlock message" $ do + let msg = imageMessage User "image/png" "base64data==" + messageRole msg @?= User + case messageContents msg of + (ImageBlock (ImageContent (ImageBase64 (Just mime) b64) Nothing Nothing) :| []) -> do + mime @?= "image/png" + b64 @?= "base64data==" + _ -> assertFailure "Expected ImageBlock" + ] + , testGroup + "Effect-Polymorphic ChatModel" + [ testCase "invoke returns Assistant response" $ do + let model = TestChatModel "Hello human" "mock-gpt" + input = [userMessage "Hi"] + res <- runExceptT $ invoke model input Nothing + case res of + Left err -> assertFailure $ "Unexpected error: " ++ show err + Right msg -> do + messageRole msg @?= Assistant + extractMessageText msg @?= "Hello human" + , testCase "batch processes multiple inputs sequentially" $ do + let model = TestChatModel "Pong" "mock-gpt" + inputs = [[userMessage "Ping 1"], [userMessage "Ping 2"]] + res <- runExceptT $ batch model inputs Nothing + case res of + Left err -> assertFailure $ "Unexpected error: " ++ show err + Right msgs -> do + length msgs @?= 2 + map extractMessageText msgs @?= ["Pong", "Pong"] + ] + ] diff --git a/test/Test/Langchain/Monad.hs b/test/Test/Langchain/Monad.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Monad.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Monad (tests) where + +import Control.Monad.Reader (ask) +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Error (internalError) +import Langchain.Monad + +tests :: TestTree +tests = + testGroup + "Test.Langchain.Monad" + [ testCase "runLangchainT executes pure computations successfully" $ do + res <- runLangchainT () (pure ("hello" :: String)) + res @?= Right "hello" + , testCase "runLangchainT propagates errors via throwLangchainError" $ do + res <- runLangchainT () $ do + throwLangchainError (internalError "test fail" Nothing Nothing) + case res of + Left _ -> pure () + Right _ -> assertFailure "Expected error" + , testCase "runLangchainT threads custom env through ask" $ do + -- Developers use ask / asks from mtl directly with their own r + let customEnv = (42 :: Int) + res <- runLangchainT customEnv ask + res @?= Right 42 + ] diff --git a/test/Test/Langchain/Observability.hs b/test/Test/Langchain/Observability.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Observability.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Observability (tests) where + +import Control.Concurrent.STM (atomically, modifyTVar') +import Control.Monad.Except (runExceptT) +import qualified Data.Map.Strict as Map +import Data.Maybe (isJust) +import qualified Data.Text as T +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Observability + +tests :: TestTree +tests = + testGroup + "Langchain.Observability" + [ testGroup + "Structured Logging" + [ testCase "InMemoryLogger records events and respects minLevel" $ do + logger <- newInMemoryLogger InfoLevel + let logHandler = + Logger + { minLevel = InfoLevel + , writeLog = \ev -> do + atomically $ modifyTVar' (inMemoryVar logger) (\ls -> ls ++ [ev]) + } + logDebug logHandler "Agent" "This debug log should be ignored" + logInfo logHandler "Agent" "Starting agent turn" + logWarn logHandler "Agent" "Model rate limit approaching" + logError logHandler "Agent" "Tool execution failed" + + logs <- getInMemoryLogs logger + length logs @?= 3 + map logLevel logs @?= [InfoLevel, WarnLevel, ErrorLevel] + , testCase "logEvent attaches custom metadata" $ do + logger <- newInMemoryLogger DebugLevel + let logHandler = + Logger + { minLevel = DebugLevel + , writeLog = \ev -> do + atomically $ modifyTVar' (inMemoryVar logger) (\ls -> ls ++ [ev]) + } + let customMeta = Map.fromList [("runId", "run-123"), ("attempt", "1")] + logEvent logHandler DebugLevel "LLM" "Prompt sent" customMeta + logs <- getInMemoryLogs logger + case logs of + [ev] -> do + logComponent ev @?= "LLM" + logMetadata ev @?= customMeta + _ -> assertFailure "Expected exactly 1 log" + ] + , testGroup + "OpenTelemetry Tracing" + [ testCase "withSpan wraps computation, records duration and Ok status" $ do + tracer <- newOTelTracer (Just "trace-unit-1") + res <- + runExceptT $ + withSpan tracer "test-operation" Nothing InternalSpan Map.empty (pure ("success" :: String)) + res @?= Right "success" + + spans <- getSpans tracer + case spans of + [sp] -> do + spanName sp @?= "test-operation" + spanTraceId sp @?= "trace-unit-1" + spanStatus sp @?= StatusOk + isJust (spanEndTime sp) @? "Expected span end time" + isJust (spanDurationMicros sp) @? "Expected duration" + _ -> assertFailure "Expected exactly 1 span" + , testCase "exportSpansJson exports valid JSON formatted trace" $ do + tracer <- newOTelTracer (Just "trace-unit-2") + _ <- runExceptT $ withSpan tracer "child-span" Nothing ClientSpan Map.empty (pure (42 :: Int)) + jsonOutput <- exportSpansJson tracer + "child-span" `T.isInfixOf` jsonOutput @? "Expected JSON to contain span name" + "trace-unit-2" `T.isInfixOf` jsonOutput @? "Expected JSON to contain trace ID" + ] + ] diff --git a/test/Test/Langchain/PromptTemplate.hs b/test/Test/Langchain/PromptTemplate.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/PromptTemplate.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.PromptTemplate (tests) where + +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.PromptTemplate +import Langchain.Runnable (invoke) + +tests :: TestTree +tests = + testGroup + "PromptTemplate" + [ testCase "correctly interpolates all variables" $ + renderPrompt greetingTemplate vars @?= Right "Hello, Alice! Welcome to Wonderland." + , testCase "handles templates with no variables" $ + let noVarTemplate = fromTemplate "Hello, world!" + in renderPrompt noVarTemplate Map.empty @?= Right "Hello, world!" + , testCase "handles templates with repeated variables" $ + let repeatTemplate = fromTemplate "{name} likes {food}. {name} eats {food} every day." + repeatVars = Map.fromList [("name", "Bob"), ("food", "pizza")] + in renderPrompt repeatTemplate repeatVars @?= Right "Bob likes pizza. Bob eats pizza every day." + , testCase "returns an error for missing variables" $ + let missingVars = Map.fromList [("name", "Charlie")] + in case renderPrompt greetingTemplate missingVars of + Left err -> "place" `T.isInfixOf` T.pack (show err) @? "Expected error to contain 'place'" + Right _ -> assertFailure "Expected an error for missing variable" + , testCase "renders escaped f-string braces" $ + let promptTemplate = fromTemplate "Hello {{name}}, {name}!" + in renderPrompt promptTemplate (Map.singleton "name" "Alice") @?= Right "Hello {name}, Alice!" + , testCase "renders f-string format specs" $ + let promptTemplate = fromTemplate "Hello, {name:~u}!" + in renderPrompt promptTemplate (Map.singleton "name" "Alice") @?= Right "Hello, ALICE!" + , testCase "infers f-string variables without escaped braces" $ + let promptTemplate = fromTemplate "Hello {{name}}, {name}!" + in inputVariables promptTemplate @?= ["name"] + , testCase "rejects f-string positional fields" $ + assertRenderErrorContains "Positional arguments are not supported" $ + renderPrompt (fromTemplate "Hello, {0}!") (Map.singleton "0" "Alice") + , testCase "rejects f-string attribute access" $ + assertRenderErrorContains "Attribute access is not supported" $ + renderPrompt (fromTemplate "Hello, {user.name}!") (Map.singleton "user.name" "Alice") + , testCase "rejects nested f-string replacement fields" $ + assertRenderErrorContains "Nested replacement fields are not allowed" $ + renderPrompt + (fromTemplate "Hello, {name:{width}}!") + (Map.fromList [("name", "Alice"), ("width", "10")]) + , testCase "partialPromptTemplate binds partial variables" $ + let pt = fromTemplate "Hello, {name}! Welcome to {place}." + ptPartial = partialPromptTemplate pt (Map.singleton "place" "Wonderland") + in renderPrompt ptPartial (Map.singleton "name" "Alice") + @?= Right "Hello, Alice! Welcome to Wonderland." + , testCase "Runnable instance invokes successfully" $ do + res <- invoke greetingTemplate vars + res @?= Right "Hello, Alice! Welcome to Wonderland." + ] + where + greetingTemplate = fromTemplate "Hello, {name}! Welcome to {place}." + vars = Map.fromList [("name", "Alice"), ("place", "Wonderland")] + +assertRenderErrorContains :: (Show err) => T.Text -> Either err T.Text -> Assertion +assertRenderErrorContains expected result = + case result of + Left err -> expected `T.isInfixOf` T.pack (show err) @? "Expected error to contain expected text" + Right _ -> assertFailure "Expected render error" diff --git a/test/Test/Langchain/Resilience.hs b/test/Test/Langchain/Resilience.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Resilience.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Resilience (tests) where + +import Control.Concurrent.STM +import Control.Monad.Except (runExceptT, throwError) +import Control.Monad.IO.Class (liftIO) +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.Error (internalError) +import Langchain.Resilience + +tests :: TestTree +tests = + testGroup + "Langchain.Resilience" + [ testGroup + "CircuitBreaker" + [ testCase "CircuitBreaker starts in Closed state and passes successful requests" $ do + cb <- newCircuitBreaker "test-cb" defaultCircuitConfig + st <- getCircuitState cb + st @?= CircuitClosed + res <- runExceptT $ withCircuitBreaker cb (pure ("ok" :: String)) + res @?= Right "ok" + , testCase "CircuitBreaker transitions to Open after exceeding failure threshold" $ do + let cfg = CircuitBreakerConfig {failureThreshold = 2, resetTimeoutSec = 0.1} + cb <- newCircuitBreaker "failing-cb" cfg + -- First failure + _ <- runExceptT $ withCircuitBreaker cb (throwError (internalError "fail 1" Nothing Nothing)) + st1 <- getCircuitState cb + st1 @?= CircuitClosed + -- Second failure -> should open + _ <- runExceptT $ withCircuitBreaker cb (throwError (internalError "fail 2" Nothing Nothing)) + st2 <- getCircuitState cb + case st2 of + CircuitOpen _ -> pure () + _ -> assertFailure "Expected CircuitOpen state" + -- Third request fast-fails without executing action + resFastFail <- runExceptT $ withCircuitBreaker cb (pure ("should not execute" :: String)) + case resFastFail of + Left _ -> pure () + Right _ -> assertFailure "Expected circuit breaker fast-fail error" + ] + , testGroup + "Retry" + [ testCase "withRetry succeeds after failing attempts" $ do + attemptVar <- newTVarIO (0 :: Int) + let policy = defaultRetryPolicy {maxRetries = 3, baseDelayMicros = 1000, useJitter = False} + action = do + curr <- liftIO $ atomically $ do + c <- readTVar attemptVar + writeTVar attemptVar (c + 1) + pure c + if curr < 2 + then throwError $ internalError "Temporary failure" Nothing Nothing + else pure ("Success on attempt " ++ show (curr + 1)) + res <- runExceptT $ withRetry policy action + res @?= Right "Success on attempt 3" + , testCase "RateLimiter consumes tokens and executes action" $ do + limiter <- newRateLimiter 5.0 5.0 + res <- withRateLimit limiter (pure (42 :: Int)) + res @?= 42 + ] + ] diff --git a/test/Test/Langchain/Retriever.hs b/test/Test/Langchain/Retriever.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Retriever.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Retriever (tests) where + +import Control.Monad.Except (runExceptT) +import qualified Data.Map.Strict as Map +import qualified Data.Text.Lazy as TL +import Test.Tasty +import Test.Tasty.HUnit + +import Langchain.DocumentLoader.Core (Document (..)) +import Langchain.Retriever + +data DummyRetriever = DummyRetriever + deriving (Show, Eq) + +instance Retriever DummyRetriever where + getRelevantDocuments _ query = + pure [Document (TL.fromStrict $ query <> " result") Map.empty] + +tests :: TestTree +tests = + testGroup + "Langchain.Retriever" + [ testGroup + "Core" + [ testCase "DummyRetriever retrieves documents" $ do + res <- runExceptT $ getRelevantDocuments DummyRetriever "test" + case res of + Left err -> assertFailure ("Error: " ++ show err) + Right docs -> map pageContent docs @?= ["test result"] + ] + , testGroup + "BM25" + [ testCase "BM25 finds exact matching document" $ do + let doc1 = + Document + { pageContent = "Haskell is a functional programming language with strong static types." + , metadata = Map.empty + } + doc2 = + Document + { pageContent = "Python is a dynamic language used for machine learning and web scripts." + , metadata = Map.empty + } + doc3 = + Document + { pageContent = "Rust guarantees memory safety without garbage collection." + , metadata = Map.empty + } + index = newBM25Index [doc1, doc2, doc3] + results = bm25Search index "functional static types" 2 + case results of + (topResult : _) -> topResult @?= doc1 + [] -> assertFailure "Expected non-empty search results" + ] + , testGroup + "Hybrid" + [ testCase "reciprocalRankFusion prioritizes documents appearing in both lists" $ do + let docA = Document {pageContent = "Document A about quantum algorithms", metadata = Map.empty} + docB = Document {pageContent = "Document B about classical physics", metadata = Map.empty} + docC = Document {pageContent = "Document C about neural networks", metadata = Map.empty} + denseList = [docA, docB] + sparseList = [docC, docA] + fused = reciprocalRankFusion 60.0 [(denseList, 1.0), (sparseList, 1.0)] + length fused @?= 3 + case fused of + ((topDoc, _) : _) -> topDoc @?= docA + [] -> assertFailure "Expected non-empty fused results" + , testCase "searchHybrid executes dense and sparse searches" $ do + let doc1 = Document {pageContent = "Haskell state monad and effects", metadata = Map.empty} + doc2 = Document {pageContent = "Rust borrow checker and lifetimes", metadata = Map.empty} + bm25 = newBM25Index [doc1, doc2] + mockVecSearch _ _ = pure [doc2, doc1] + hybrid = newHybridRetriever bm25 mockVecSearch + results <- searchHybrid hybrid "Haskell" 2 + length results @?= 2 + case results of + (topDoc : _) -> topDoc @?= doc1 + [] -> assertFailure "Expected non-empty results" + ] + ] diff --git a/test/Test/Langchain/Runnable.hs b/test/Test/Langchain/Runnable.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Runnable.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Langchain.Runnable (tests) where + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck as QC + +import Control.Monad.Except (ExceptT, runExceptT) +import qualified Data.Text as T + +import Langchain.Error +import Langchain.Runnable + +type TestMonad = ExceptT LangchainError IO + +-- Pure test lambda helpers +addOneLambda :: RunnableTree TestMonad Int Int +addOneLambda = runLambda $ \x -> pure (Right (x + 1)) + +doubleLambda :: RunnableTree TestMonad Int Int +doubleLambda = runLambda $ \x -> pure (Right (x * 2)) + +failLambda :: RunnableTree TestMonad Int Int +failLambda = runLambda $ \_ -> pure (Left $ runnableError "Pipeline failed" Nothing Nothing) + +tests :: TestTree +tests = + testGroup + "Langchain.Runnable" + [ testGroup + "Identity Laws" + [ testCase "Left Identity: Id |>> t == t" $ do + let t = addOneLambda + r1 <- runExceptT $ interpret (Id |>> t) 5 + r2 <- runExceptT $ interpret t 5 + r1 @?= Right 6 + r1 @?= r2 + , testCase "Right Identity: t |>> Id == t" $ do + let t = addOneLambda + r1 <- runExceptT $ interpret (t |>> Id) 5 + r2 <- runExceptT $ interpret t 5 + r1 @?= Right 6 + r1 @?= r2 + ] + , testGroup + "Sequential Composition Laws" + [ testCase "Seq executes in left-to-right order" $ do + let pipeline = addOneLambda |>> doubleLambda -- (5 + 1) * 2 = 12 + res <- runExceptT $ interpret pipeline 5 + res @?= Right 12 + , testCase "Seq propagates errors early" $ do + let pipeline = failLambda |>> doubleLambda + res <- runExceptT $ interpret pipeline 5 + case res of + Left (RunnableError msg _) -> assertBool "Should contain error message" ("failed" `T.isInfixOf` msg) + _ -> assertFailure "Expected RunnableError" + ] + , testGroup + "Parallel Composition Laws (&>&)" + [ testCase "Par executes branches concurrently" $ do + let pipeline = addOneLambda &>& doubleLambda + res <- runExceptT $ interpret pipeline 10 + res @?= Right (11, 20) + ] + , testGroup + "Branching and Fallback" + [ testCase "Branch selects True branch" $ do + let pipeline = Branch (\x -> pure (x > 0)) addOneLambda doubleLambda + res <- runExceptT $ interpret pipeline 5 + res @?= Right 6 + , testCase "Branch selects False branch" $ do + let pipeline = Branch (\x -> pure (x > 0)) addOneLambda doubleLambda + res <- runExceptT $ interpret pipeline (-5) + res @?= Right (-10) + , testCase "Fallback executes secondary when primary fails" $ do + let pipeline = Fallback failLambda doubleLambda + res <- runExceptT $ interpret pipeline 7 + res @?= Right 14 + ] + , testGroup + "Property Tests (QuickCheck)" + [ QC.testProperty "Identity Law: Id |>> t(x) == t(x)" $ \(x :: Int) -> + QC.ioProperty $ do + r1 <- runExceptT $ interpret (Id |>> addOneLambda) x + r2 <- runExceptT $ interpret addOneLambda x + pure (r1 == r2) + , QC.testProperty "Associativity: (f |>> g) |>> h == f |>> (g |>> h)" $ \(x :: Int) -> + QC.ioProperty $ do + let f = addOneLambda + g = doubleLambda + h = addOneLambda + p1 = (f |>> g) |>> h + p2 = f |>> (g |>> h) + r1 <- runExceptT $ interpret p1 x + r2 <- runExceptT $ interpret p2 x + pure (r1 == r2) + ] + ] diff --git a/test/Test/Langchain/Stream.hs b/test/Test/Langchain/Stream.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Stream.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Langchain.Stream (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Control.Monad.Except (runExceptT) +import Control.Monad.Trans.Resource (runResourceT) + +import Langchain.Model +import Langchain.Stream +import Test.Langchain.TestModel (TestChatModel (..)) + +tests :: TestTree +tests = + testGroup + "Langchain.Stream" + [ testCase "stream emits LLMStart, LLMChunk, LLMEnd events" $ do + let model = TestChatModel "Streamed content" "mock-gpt" + input = [userMessage "Stream test"] + res <- runResourceT $ runExceptT $ collectEvents (stream model input Nothing) + case res of + Left err -> assertFailure $ "Unexpected stream error: " ++ show err + Right events -> do + length events @?= 3 + case events of + [s@LLMStart {}, c@LLMChunk {}, e@LLMEnd {}] -> do + modelName s @?= "mock-gpt" + chunkText c @?= "Streamed content" + extractMessageText (finalMessage e) @?= "Streamed content" + _ -> assertFailure $ "Unexpected event sequence: " ++ show events + ] diff --git a/test/Test/Langchain/TestModel.hs b/test/Test/Langchain/TestModel.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/TestModel.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Langchain.TestModel + ( TestChatModel (..) + ) where + +import Data.Conduit (yield) +import Data.Text (Text) + +import Langchain.Model +import Langchain.Stream (StreamEvent (..)) + +data TestChatModel = TestChatModel + { testResponse :: Text + , testModelName :: Text + } + deriving (Eq, Show) + +instance ChatModel TestChatModel where + type ModelConfig TestChatModel = () + + invoke model _ _ = pure $ assistantMessage (testResponse model) + + stream model inputMsgs _ = do + let rId = "test-run-id" + yield $ LLMStart rId (testModelName model) inputMsgs + yield $ LLMChunk rId (testResponse model) Nothing + yield $ LLMEnd rId (assistantMessage $ testResponse model) Nothing diff --git a/test/Test/Langchain/Tool.hs b/test/Test/Langchain/Tool.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Tool.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Langchain.Tool (tests) where + +import Data.Aeson +import Data.Aeson.Types (parseEither) +import Data.Text (Text) +import Langchain.Error +import Langchain.Tool +import Test.Tasty +import Test.Tasty.HUnit + +calcExec :: Value -> IO (Either LangchainError Text) +calcExec (Object _) = pure $ Right "42" +calcExec _ = pure $ Left $ toolError "Invalid arguments" (Just "calc") Nothing + +tests :: TestTree +tests = + testGroup + "Langchain.Tool" + [ testCase "createTool initializes tool attributes" $ do + let t = createTool "calculator" "Performs math" (object []) calcExec + toolName t @?= "calculator" + toolDescription t @?= "Performs math" + , testCase "toolToValue generates correct JSON schema structure" $ do + let t = createTool "calculator" "Performs math" (object ["type" .= ("object" :: Text)]) calcExec + val = toolToValue t + case val of + Object o -> do + case parseEither (.: "type") o of + Right ("function" :: Text) -> pure () + res -> assertFailure $ "Expected type = function, got: " ++ show res + _ -> assertFailure "Expected JSON Object" + , testCase "toolExecute runs successfully on valid input" $ do + let t = createTool "calculator" "Performs math" (object []) calcExec + res <- toolExecute t (object []) + res @?= Right "42" + ]