diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,14 @@ +# Changelog for `langchain-hs-core` + +All notable changes to this package will be documented in this file. + +## 0.0.5.0 - 2026-09-10 + +- Initial standalone Hackage release of `langchain-hs-core`. +- Zero-dependency pure core architecture. +- First-class `RunnableTree` GADT AST with sequential (`|>>`), parallel (`&>&`), and fallback (`>>>#`) operators. +- `ChatModel` effect-polymorphic interface. +- Multi-modal `ContentBlock` and message structures. +- Conduit-based `StreamEvent` and streaming protocol. +- Decoupled `LangchainT env m a` transformer. +- Typed `Tool` and `FunctionDefinition`. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2025-2026 Tushar Adhatrao + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,24 @@ +# `langchain-hs-core` + +> Zero-dependency pure core of the `langchain-hs` 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. + +## Key Primitives + +- **`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`. + +## Installation + +```cabal +build-depends: langchain-hs-core >= 0.0.5 && < 0.0.6 +``` + +## License + +MIT License. See [LICENSE](LICENSE). diff --git a/langchain-hs-core.cabal b/langchain-hs-core.cabal new file mode 100644 --- /dev/null +++ b/langchain-hs-core.cabal @@ -0,0 +1,118 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.39.6. +-- +-- see: https://github.com/sol/hpack + +name: langchain-hs-core +version: 0.0.5.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 +homepage: https://github.com/tusharad/langchain-hs#readme +bug-reports: https://github.com/tusharad/langchain-hs/issues +author: Tushar Adhatrao +maintainer: tusharadhatrao@gmail.com +copyright: 2025-2026 Tushar Adhatrao +license: MIT +license-file: LICENSE +build-type: Simple +tested-with: + GHC == 9.12.4 + , GHC == 9.10.3 + , GHC == 9.8.4 +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/tusharad/langchain-hs + +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 + other-modules: + Paths_langchain_hs_core + hs-source-dirs: + src + default-extensions: + MultiParamTypeClasses + FunctionalDependencies + TypeFamilies + TypeOperators + DataKinds + GADTs + OverloadedStrings + DeriveGeneric + DeriveAnyClass + RecordWildCards + FlexibleContexts + build-depends: + aeson >=2.0 && <3 + , async ==2.2.* + , base >=4.17 && <5 + , base64-bytestring ==1.2.* + , bytestring >=0.10 && <0.13 + , conduit ==1.3.* + , containers >=0.6 && <0.9 + , deepseq >=1.4 && <1.6 + , mtl >=2.2 && <2.4 + , resourcet >=1.2 && <1.4 + , stm ==2.5.* + , text >=1.2 && <3 + , time >=1.9 && <1.15 + default-language: Haskell2010 + +test-suite langchain-hs-core-test + 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 + Paths_langchain_hs_core + hs-source-dirs: + test + default-extensions: + MultiParamTypeClasses + FunctionalDependencies + TypeFamilies + TypeOperators + DataKinds + GADTs + OverloadedStrings + DeriveGeneric + DeriveAnyClass + RecordWildCards + FlexibleContexts + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck >=2.14 + , aeson >=2.0 && <3 + , async ==2.2.* + , base >=4.17 && <5 + , base64-bytestring ==1.2.* + , bytestring >=0.10 && <0.13 + , conduit ==1.3.* + , containers >=0.6 && <0.9 + , deepseq >=1.4 && <1.6 + , langchain-hs-core + , mtl >=2.2 && <2.4 + , resourcet + , stm ==2.5.* + , tasty >=1.4 + , tasty-hunit >=0.10 + , tasty-quickcheck >=0.10 + , text >=1.2 && <3 + , time >=1.9 && <1.15 + default-language: Haskell2010 diff --git a/src/Langchain/Core/Error.hs b/src/Langchain/Core/Error.hs new file mode 100644 --- /dev/null +++ b/src/Langchain/Core/Error.hs @@ -0,0 +1,178 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Langchain/Core/Model.hs @@ -0,0 +1,53 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Langchain/Core/Model/Types.hs @@ -0,0 +1,199 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Langchain/Core/Monad.hs @@ -0,0 +1,55 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Langchain/Core/Runnable.hs @@ -0,0 +1,194 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Langchain/Core/Stream.hs @@ -0,0 +1,169 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Langchain/Core/Tool.hs @@ -0,0 +1,65 @@ +{-# 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/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,23 @@ +module Main (main) where + +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 + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = + testGroup + "langchain-hs-core" + [ RunnableTest.tests + , ModelTest.tests + , StreamTest.tests + , ToolTest.tests + , MonadTest.tests + ] diff --git a/test/Test/Langchain/Core/Model.hs b/test/Test/Langchain/Core/Model.hs new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Core/Model.hs @@ -0,0 +1,60 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Core/Monad.hs @@ -0,0 +1,30 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Core/Runnable.hs @@ -0,0 +1,100 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Core/Stream.hs @@ -0,0 +1,33 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Core/TestModel.hs @@ -0,0 +1,29 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/test/Test/Langchain/Core/Tool.hs @@ -0,0 +1,39 @@ +{-# 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" + ]