packages feed

intelli-monad 0.1.1.1 → 0.1.2.0

raw patch · 16 files changed

+483/−361 lines, 16 filesdep +hspecdep −openai-servant-gendep −servantdep −servant-clientdep ~aesondep ~bytestringdep ~exceptions

Dependencies added: hspec

Dependencies removed: openai-servant-gen, servant, servant-client, servant-client-core, servant-server

Dependency ranges changed: aeson, bytestring, exceptions, text, time, transformers, vector

Files

intelli-monad.cabal view
@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               intelli-monad-version:            0.1.1.1+version:            0.1.2.0 synopsis:           Type level prompt with LLMs via louter. description:        Type level prompt with LLMs via louter. This allows us to define function calls and value validation using types. homepage:           https://github.com/junjihashimoto/intelli-monad@@ -40,8 +40,6 @@                     , IntelliMonad.Tools                     , IntelliMonad.Tools.Arxiv                     , IntelliMonad.Tools.Bash-                    , IntelliMonad.Tools.TextToSpeech-                    , IntelliMonad.Tools.DallE3                     , IntelliMonad.Tools.Utils                     , IntelliMonad.Tools.KeyValue                     , IntelliMonad.Persist@@ -76,9 +74,6 @@                     , http-conduit >= 2.2 && < 2.4                     , megaparsec >= 9.5 && < 9.7                     , louter >= 0.1.1 && < 0.1.2-                    , openai-servant-gen >= 0.1.0 && < 0.2-                    , servant >= 0.20.1 && < 0.22-                    , servant-client >= 0.20 && < 0.21                     , persistent >= 2.14.6 && < 2.15                     , persistent-sqlite >= 2.13.3 && < 2.14                     , sixel >= 0.1.2 && < 0.2@@ -88,10 +83,8 @@                     , yaml >= 0.11 && < 0.12                     , wai >=3.2 && <4.0                     , warp >=3.3 && <4.0-                    , servant-server >= 0.20 && < 0.21-                    , servant-client-core >= 0.20 && < 0.21                     , mtl >=2.2 && <3.0-                    , exceptions >=1.10 && <1.11+                    , exceptions >=0.10 && <1.0                     , wai-extra >=3.1 && <3.2                     , stm >=2.5 && <2.6                     , kan-extensions >=5.2 && <5.3@@ -149,7 +142,7 @@     default-language: Haskell2010      -- Modules included in this executable, other than Main.-    -- other-modules:+    other-modules:    ArxivSpec      -- LANGUAGE extensions used by modules in this package.     -- other-extensions:@@ -161,9 +154,16 @@     hs-source-dirs:   test      -- The entrypoint to the test suite.-    main-is:          Main.hs+    main-is:          Spec.hs      -- Test dependencies.     build-depends:         base ==4.*,-        intelli-monad+        intelli-monad,+        hspec >=2.0,+        aeson,+        text,+        bytestring,+        vector,+        transformers,+        time
src/IntelliMonad/Cmd.hs view
@@ -35,7 +35,6 @@ import IntelliMonad.Repl import IntelliMonad.Tools import IntelliMonad.Types-import qualified OpenAI.Types as API import Options.Applicative import System.Console.Haskeline import System.Environment (lookupEnv)@@ -80,7 +79,7 @@   let tools = defaultTools       customs = []       sessionName = "default"-      defaultReq = LouterRequest (defaultRequest @OpenAI)+      defaultReq = defaultRequest   runInputT     ( Settings         { complete = completeFilename,
src/IntelliMonad/CustomInstructions.hs view
@@ -24,7 +24,6 @@ import Data.Proxy import GHC.Generics import IntelliMonad.Types-import qualified OpenAI.Types as API  defaultCustomInstructions :: [CustomInstructionProxy] defaultCustomInstructions = []
src/IntelliMonad/Prompt.hs view
@@ -37,11 +37,10 @@ import IntelliMonad.Persist import IntelliMonad.Tools import IntelliMonad.Types+import qualified Louter.Types.Request as Louter+import qualified Louter.Types.Response as Louter import Network.HTTP.Client (managerResponseTimeout, newManager, responseTimeoutMicro) import Network.HTTP.Client.TLS (tlsManagerSettings)-import qualified OpenAI.API as API-import qualified OpenAI.Types as API-import Servant.Client (mkClientEnv, parseBaseUrl) import System.Environment (getEnv, lookupEnv)  getContext :: (MonadIO m, MonadFail m) => Prompt m Context@@ -208,7 +207,7 @@   [ToolProxy] ->   [CustomInstructionProxy] ->   Text ->-  LLMRequest ->+  Louter.ChatRequest ->   Text ->   m (Maybe validation) runPromptWithValidation tools customs sessionName req input = do@@ -259,7 +258,7 @@     push @p contents     call @p >>= callWithValidation @output @StatelessConf -initializePrompt :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => [ToolProxy] -> [CustomInstructionProxy] -> Text -> LLMRequest -> m PromptEnv+initializePrompt :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => [ToolProxy] -> [CustomInstructionProxy] -> Text -> Louter.ChatRequest -> m PromptEnv initializePrompt tools customs sessionName req = do --  config <- readConfig   let settings = addTools tools req@@ -297,7 +296,7 @@         initialize @p conn (init'.context)         return init' -runPrompt :: forall p m a. (MonadIO m, MonadFail m, PersistentBackend p) => [ToolProxy] -> [CustomInstructionProxy] -> Text -> LLMRequest -> Prompt m a -> m a+runPrompt :: forall p m a. (MonadIO m, MonadFail m, PersistentBackend p) => [ToolProxy] -> [CustomInstructionProxy] -> Text -> Louter.ChatRequest -> Prompt m a -> m a runPrompt tools customs sessionName req func = do   context <- initializePrompt @p tools customs sessionName req   fst <$> runStateT func context
src/IntelliMonad/Repl.hs view
@@ -33,7 +33,7 @@ import IntelliMonad.Persist import IntelliMonad.Prompt hiding (user, system, assistant) import IntelliMonad.Types-import qualified OpenAI.Types as API+import qualified Louter.Types.Request as Louter import System.Console.Haskeline import System.Environment (lookupEnv) import System.IO (hClose)@@ -107,7 +107,7 @@       ExitSuccess -> Just <$> T.readFile filePath       ExitFailure _ -> return Nothing -editRequestWithEditor :: forall m. (MonadIO m, MonadFail m) => LLMRequest -> m (Maybe LLMRequest)+editRequestWithEditor :: forall m. (MonadIO m, MonadFail m) => Louter.ChatRequest -> m (Maybe Louter.ChatRequest) editRequestWithEditor req = do   liftIO $ withSystemTempFile "tempfile.yaml" $ \filePath fileHandle -> do     hClose fileHandle@@ -119,7 +119,7 @@     code <- system (editor <> " " <> filePath)     case code of       ExitSuccess -> do-        newReq <- Y.decodeFileEither @LLMRequest filePath+        newReq <- Y.decodeFileEither @Louter.ChatRequest filePath         case newReq of           Right newReq' -> return $ Just newReq'           Left err -> do@@ -322,7 +322,7 @@   cmd <- getUserCommand @p   runCmd' @p cmd (Just (runRepl' @p)) -runRepl :: forall p. (PersistentBackend p) => [ToolProxy] -> [CustomInstructionProxy] -> Text -> LLMRequest -> Contents -> IO ()+runRepl :: forall p. (PersistentBackend p) => [ToolProxy] -> [CustomInstructionProxy] -> Text -> Louter.ChatRequest -> Contents -> IO () runRepl tools customs sessionName defaultReq contents = do   config <- readConfig   runInputT
src/IntelliMonad/Tools.hs view
@@ -21,8 +21,6 @@   ( module IntelliMonad.Tools.Utils,     module IntelliMonad.Tools.Arxiv,     module IntelliMonad.Tools.Bash,-    module IntelliMonad.Tools.TextToSpeech,-    module IntelliMonad.Tools.DallE3,     defaultTools,   ) where@@ -30,18 +28,12 @@ import Data.Proxy import IntelliMonad.Tools.Arxiv import IntelliMonad.Tools.Bash-import IntelliMonad.Tools.DallE3-import IntelliMonad.Tools.TextToSpeech import IntelliMonad.Tools.Utils import IntelliMonad.Types  arxiv = ToolProxy (Proxy :: Proxy Arxiv)  bash = ToolProxy (Proxy :: Proxy Bash)--textToSpeech = ToolProxy (Proxy :: Proxy TextToSpeech)--dallE3 = ToolProxy (Proxy :: Proxy DallE3)  defaultTools :: [ToolProxy] defaultTools =
src/IntelliMonad/Tools/Arxiv.hs view
@@ -62,7 +62,6 @@ import Network.HTTP.Client import Network.HTTP.Client.TLS import Network.HTTP.Simple (setRequestQueryString)-import qualified OpenAI.Types as API import Text.XML import Text.XML.Cursor (Axis, Cursor, attributeIs, checkName, content, element, fromDocument, ($//), (&/), (&//))
src/IntelliMonad/Tools/Bash.hs view
@@ -25,7 +25,6 @@ import GHC.Generics import GHC.IO.Exception import IntelliMonad.Types-import qualified OpenAI.Types as API import System.Process  data Bash = Bash
− src/IntelliMonad/Tools/DallE3.hs 
@@ -1,113 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE OverloadedRecordDot #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}--module IntelliMonad.Tools.DallE3 where--import Codec.Picture-import Control.Monad.IO.Class-import qualified Data.Aeson as A-import qualified Data.ByteString.Lazy as LBS-import Data.Maybe (fromMaybe)-import qualified Data.OSC1337 as OSC-import qualified Data.Sixel as Sixel-import Data.Text (Text)-import qualified Data.Text as T-import GHC.Generics-import IntelliMonad.Types-import Network.HTTP.Client (httpLbs, newManager, parseUrlThrow, responseBody)-import Network.HTTP.Client.TLS (tlsManagerSettings)-import qualified OpenAI.API as API-import qualified OpenAI.Types as API-import Servant.Client-import System.Environment (getEnv, lookupEnv)--putImage :: FilePath -> IO (Either String ())-putImage image' = do-  termProgram <- lookupEnv "TERM_PROGRAM"-  imageBin <- readImage image'-  case imageBin of-    Left err -> return $ Left $ "Image file " ++ image' ++ " can not be read. : " ++ show err-    Right imageBin' -> do-      let image = convertRGB8 imageBin'-      case termProgram of-        Just "iTerm.app" -> do-          OSC.putOSC image-          putStrLn ""-        Just "vscode" -> do-          Sixel.putSixel image-          putStrLn ""-        _ -> do-          Sixel.putSixel image-          putStrLn ""-      return $ Right ()--data DallE3 = DallE3-  { prompt :: T.Text,-    size :: T.Text-  }-  deriving (Eq, Show, Generic, JSONSchema, A.FromJSON, A.ToJSON)--instance HasFunctionObject DallE3 where-  getFunctionName = "image_generation"-  getFunctionDescription = "Creating images from scratch based on a text prompt"-  getFieldDescription "prompt" = "A text description of the desired image. The maximum length is 4000 characters."-  getFieldDescription "size" = "The size of the generated images. Must be one of 1024x1024, 1792x1024, or 1024x1792 for dall-e-3 models."--instance Tool DallE3 where-  data Output DallE3 = DallE3Output-    { code :: Int,-      stdout :: String,-      stderr :: String,-      url :: Text-    }-    deriving (Eq, Show, Generic, A.FromJSON, A.ToJSON)-  toolExec args = liftIO $ do-    api_key <- (API.clientAuth . T.pack) <$> getEnv "OPENAI_API_KEY"-    url <- parseBaseUrl "https://api.openai.com/v1/"-    manager <- newManager tlsManagerSettings-    let API.OpenAIBackend {..} = API.createOpenAIClient-    let request =-          API.CreateImageRequest-            { createImageRequestPrompt = args.prompt,-              createImageRequestModel = Just $ API.CreateImageRequestModel "dall-e-3",-              createImageRequestN = Nothing,-              createImageRequestQuality = Nothing,-              createImageRequestResponseUnderscoreformat = Just "url",-              createImageRequestSize = Just args.size,-              createImageRequestStyle = Nothing,-              createImageRequestUser = Nothing-            }-    res <- API.callOpenAI (mkClientEnv manager url) $ createImage api_key request-    let url' = case res of-          (API.ImagesResponse _ (img : _)) -> fromMaybe "" (API.imageUrl img)-          _ -> ""-    let downloadImage = do-          request' <- parseUrlThrow $ T.unpack url'-          manager' <- newManager tlsManagerSettings-          response <- httpLbs request' manager'-          let imageBytes = Network.HTTP.Client.responseBody response-          LBS.writeFile "image.png" imageBytes-    downloadImage-    err <- do-      liftIO $-        putImage "image.png" >>= \case-          Left err -> return err-          Right _ -> return ""-    return $ DallE3Output 0 "" err url'
src/IntelliMonad/Tools/KeyValue.hs view
@@ -31,7 +31,6 @@ import IntelliMonad.Persist import IntelliMonad.Prompt import IntelliMonad.Types-import qualified OpenAI.Types as API import System.Process import Data.Proxy
− src/IntelliMonad/Tools/TextToSpeech.hs 
@@ -1,76 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE OverloadedRecordDot #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}--module IntelliMonad.Tools.TextToSpeech where--import Control.Monad.IO.Class-import qualified Data.Aeson as A-import qualified Data.ByteString as BS-import qualified Data.Text as T-import Data.Proxy-import GHC.Generics-import GHC.IO.Exception-import IntelliMonad.Types-import Network.HTTP.Client (newManager)-import Network.HTTP.Client.TLS (tlsManagerSettings)-import qualified OpenAI.API as API-import qualified OpenAI.Types as API-import Servant.Client-import System.Environment (getEnv)-import System.Process--data TextToSpeech = TextToSpeech-  { script :: T.Text-  }-  deriving (Eq, Show, Generic, JSONSchema, A.FromJSON, A.ToJSON)--instance HasFunctionObject TextToSpeech where-  getFunctionName = "text_to_speech"-  getFunctionDescription = "Speak text"-  getFieldDescription "script" = "A script for speech"--instance Tool TextToSpeech where-  data Output TextToSpeech = TextToSpeechOutput-    { code :: Int,-      stdout :: String,-      stderr :: String-    }-    deriving (Eq, Show, Generic, A.FromJSON, A.ToJSON)-  toolExec args = liftIO $ do-    api_key <- (API.clientAuth . T.pack) <$> (getEnv "OPENAI_API_KEY")-    url <- parseBaseUrl "https://api.openai.com/v1/"-    manager <- newManager tlsManagerSettings-    let API.OpenAIBackend {..} = API.createOpenAIClient-    let request =-          API.CreateSpeechRequest-            { API.createSpeechRequestModel = API.CreateSpeechRequestModel "tts-1",-              API.createSpeechRequestInput = (script args :: T.Text),-              API.createSpeechRequestVoice = "alloy",-              API.createSpeechRequestResponseUnderscoreformat = Just "mp3",-              API.createSpeechRequestSpeed = Nothing-            }-    res <- API.callOpenAI (mkClientEnv manager url) $ createSpeech api_key request-    BS.writeFile "out.mp3" res-    (code, stdout, stderr) <- readCreateProcessWithExitCode (shell $ "afplay " <> "out.mp3") ""-    let code' = case code of-          ExitSuccess -> 0-          ExitFailure v -> v-    return $ TextToSpeechOutput code' stdout stderr
src/IntelliMonad/Tools/Utils.hs view
@@ -30,7 +30,6 @@ import qualified Data.Text.Encoding as T import Data.Time import IntelliMonad.Types-import qualified OpenAI.Types as API  toolExec' ::   forall t p m.
src/IntelliMonad/Types.hs view
@@ -40,7 +40,9 @@ import qualified Data.Aeson as A import qualified Data.Aeson.Key as A import qualified Data.Aeson.KeyMap as A+import qualified Data.Aeson.KeyMap as HM import qualified Data.Aeson.Text as A+import Data.List (nub) import Data.ByteString (ByteString, fromStrict, toStrict) import Data.Coerce import Data.Kind (Type)@@ -148,6 +150,13 @@   getFunctionDescription :: String   getFieldDescription :: String -> String +-- | Constructor schema for sum types+data ConstructorSchema = ConstructorSchema+  { csName :: Text           -- ^ Constructor name+  , csPayload :: Schema      -- ^ Payload schema+  , csIsNullary :: Bool      -- ^ True for zero-field constructors+  } deriving (Show, Eq)+ data Schema   = Maybe' Schema   | String'@@ -157,6 +166,11 @@   | Array' Schema   | Boolean'   | Null'+  -- Sum type schemas+  | Enum' [Text]                       -- ^ String enum for nullary constructors+  | OneOfUntagged [ConstructorSchema]  -- ^ Untagged union (distinguishable shapes)+  | OneOfTagged [ConstructorSchema]    -- ^ Tagged union with @tag/@value+  deriving (Show, Eq)  class GSchema s f where   gschema :: forall a. f a -> Schema@@ -166,51 +180,9 @@   default schema :: (HasFunctionObject r, Generic r, GSchema r (Rep r)) => Schema   schema = gschema @r (from (undefined :: r)) -data OpenAI--data LLMProtocol-  = OpenAI--data LLMRequest-  = LouterRequest Louter.ChatRequest-  deriving (Show, Eq, Generic)--data LLMResponse-  = LouterResponse Louter.ChatResponse-  deriving (Show, Eq, Generic)--data LLMTool-  = LouterTool Louter.Tool-  deriving (Show, Eq, Generic)--instance ToJSON LLMRequest-instance FromJSON LLMRequest-instance ToJSON LLMResponse-instance FromJSON LLMResponse---- Manual Ord instances (Louter types don't have Ord)-instance Ord LLMRequest where-  compare _ _ = EQ  -- Simplified: treat all requests as equal for ordering--instance Ord LLMResponse where-  compare _ _ = EQ  -- Simplified: treat all responses as equal for ordering--instance Ord LLMTool where-  compare _ _ = EQ  -- Simplified: treat all tools as equal for ordering--class LLMApi api where-  type LLMRequest' api-  type LLMResponse' api-  type LLMTool' api-  defaultRequest :: LLMRequest' api-  newTool :: forall a. (HasFunctionObject a, JSONSchema a) => Proxy a -> LLMTool' api-  toTools :: LLMRequest' api -> [LLMTool' api]-  fromTools :: LLMRequest' api -> [LLMTool' api] -> LLMRequest' api-  fromModel_ :: Text -> LLMRequest' api- class ChatCompletion b where-  toRequest :: LLMRequest -> b -> LLMRequest-  fromResponse :: Text -> LLMResponse -> (b, FinishReason)+  toRequest :: Louter.ChatRequest -> b -> Louter.ChatRequest+  fromResponse :: Text -> Louter.ChatResponse -> (b, FinishReason)  toPV :: (ToJSON a) => a -> PersistValue toPV = toPersistValue . toStrict . encode@@ -250,22 +222,8 @@ instance PersistFieldSql Message where   sqlType _ = sqlType (Proxy @ByteString) -instance PersistField LLMRequest where-  toPersistValue = toPV-  fromPersistValue = fromPV -instance PersistField LLMResponse where-  toPersistValue = toPV-  fromPersistValue = fromPV -instance PersistFieldSql LLMRequest where-  sqlType _ = sqlType (Proxy @ByteString)--instance PersistFieldSql LLMResponse where-  sqlType _ = sqlType (Proxy @ByteString)--- share   [mkPersist sqlSettings, mkMigrate "migrateAll"]   [persistLowerCase|@@ -281,8 +239,8 @@     deriving FromJSON     deriving Generic Context-    request LLMRequest-    response LLMResponse Maybe+    request Louter.ChatRequest+    response Louter.ChatResponse Maybe     header [Content]     body [Content]     footer [Content]@@ -291,7 +249,6 @@     created UTCTime default=CURRENT_TIME     deriving Show     deriving Eq-    deriving Ord KeyValue     namespace Text     key Text@@ -302,6 +259,15 @@     deriving Ord |] +-- Manual Ord instance for Context+-- We compare only the fields that have Ord, ignoring request and response+instance Ord Context where+  compare c1 c2 =+    compare (contextHeader c1, contextBody c1, contextFooter c1,+             contextTotalTokens c1, contextSessionName c1, contextCreated c1)+            (contextHeader c2, contextBody c2, contextFooter c2,+             contextTotalTokens c2, contextSessionName c2, contextCreated c2)+ data ToolProxy = forall t. (Tool t, A.FromJSON t, A.ToJSON t, A.FromJSON (Output t), A.ToJSON (Output t), HasFunctionObject t, JSONSchema t) => ToolProxy (Proxy t)  class CustomInstruction a where@@ -390,7 +356,78 @@       ]   Boolean' -> A.Object [("type", "boolean")]   Null' -> A.Object [("type", "null")]+  -- Sum type schemas+  Enum' constructors ->+    A.Object+      [ ("type", "string"),+        ("enum", A.Array $ V.fromList $ map A.String constructors)+      ]+  OneOfUntagged constructors ->+    A.Object+      [ ("oneOf", A.Array $ V.fromList $ map constructorToUntaggedSchema constructors)+      ]+  OneOfTagged constructors ->+    A.Object+      [ ("oneOf", A.Array $ V.fromList $ map constructorToTaggedSchema constructors)+      ] +-- | Convert a constructor schema to an untagged JSON schema+constructorToUntaggedSchema :: ConstructorSchema -> A.Value+constructorToUntaggedSchema (ConstructorSchema name payload _) =+  -- For untagged, just emit the payload schema+  -- The constructor name is used for documentation but not in the schema itself+  toAeson payload++-- | Convert a constructor schema to a tagged JSON schema with @tag/@value+constructorToTaggedSchema :: ConstructorSchema -> A.Value+constructorToTaggedSchema (ConstructorSchema name payload isNullary) =+  if isNullary+    then+      -- Nullary constructor: {"@tag": "ConstructorName"}+      A.Object+        [ ("type", "object"),+          ("properties", A.Object+            [ ("@tag", A.Object [("type", "string"), ("const", A.String name)])+            ]),+          ("required", A.Array $ V.fromList [A.String "@tag"]),+          ("additionalProperties", A.Bool False)+        ]+    else+      case payload of+        Object' _ ->+          -- Object payload: flat tagged format {"@tag": "Ctor", "field1": ..., "field2": ...}+          case toAeson payload of+            A.Object payloadObj ->+              let tagProp = ("@tag", A.Object [("type", "string"), ("const", A.String name)])+                  -- Extract properties from payload+                  props = case HM.lookup "properties" payloadObj of+                    Just (A.Object p) -> p+                    _ -> HM.empty+                  -- Extract required fields+                  req = case HM.lookup "required" payloadObj of+                    Just (A.Array r) -> V.toList r+                    _ -> []+                  -- Merge @tag with payload properties+                  allProps = HM.insert "@tag" (A.Object [("type", "string"), ("const", A.String name)]) props+                  allRequired = A.String "@tag" : req+              in A.Object+                  [ ("type", "object"),+                    ("properties", A.Object allProps),+                    ("required", A.Array $ V.fromList allRequired)+                  ]+            _ -> A.Null  -- Shouldn't happen+        _ ->+          -- Non-object payload: nested format {"@tag": "Ctor", "@value": ...}+          A.Object+            [ ("type", "object"),+              ("properties", A.Object+                [ ("@tag", A.Object [("type", "string"), ("const", A.String name)]),+                  ("@value", toAeson payload)+                ]),+              ("required", A.Array $ V.fromList [A.String "@tag", A.String "@value"]),+              ("additionalProperties", A.Bool False)+            ]+ instance Semigroup Schema where   (<>) (Object' a) (Object' b) = Object' (a <> b)   (<>) (Array' a) (Array' b) = Array' (a <> b)@@ -428,7 +465,66 @@ instance JSONSchema () where   schema = Null' -instance (HasFunctionObject s, JSONSchema c) => GSchema s U1 where+-- | Helper functions for sum type schema generation++-- | Internal wrapper to track constructor schemas during generic traversal+-- This allows us to distinguish between a single constructor and a sum type+data SchemaOrConstructors+  = SingleSchema Schema  -- ^ Not a sum type, just a regular schema+  | Constructors [ConstructorSchema]  -- ^ Sum type with multiple constructors+  deriving (Show, Eq)++-- | Extract constructors from a schema, wrapping non-sum schemas as single-constructor lists+extractConstructors :: Schema -> [ConstructorSchema]+extractConstructors (Enum' names) = map (\n -> ConstructorSchema n Null' True) names+extractConstructors (OneOfUntagged cs) = cs+extractConstructors (OneOfTagged cs) = cs+extractConstructors other = [ConstructorSchema "" other (isNullarySchema other)]++-- | Normalize constructor name (e.g., "Red" -> "red")+normalizeConstructorName :: Text -> Text+normalizeConstructorName = T.toLower++-- | Check if a schema represents a nullary constructor+isNullarySchema :: Schema -> Bool+isNullarySchema Null' = True+isNullarySchema _ = False++-- | Check if all constructors are nullary (enum pattern)+isEnum :: [ConstructorSchema] -> Bool+isEnum = all csIsNullary++-- | Extract schema shape for distinguishability check+-- Two schemas are distinguishable if they have different shapes+schemaShape :: Schema -> Text+schemaShape String' = "string"+schemaShape Number' = "number"+schemaShape Integer' = "integer"+schemaShape Boolean' = "boolean"+schemaShape Null' = "null"+schemaShape (Array' _) = "array"+schemaShape (Object' fields) = "object:" <> T.intercalate "," (map (\(n,_,_) -> T.pack n) fields)+schemaShape (Maybe' s) = "maybe:" <> schemaShape s+schemaShape (Enum' _) = "enum"+schemaShape (OneOfUntagged _) = "oneof-untagged"+schemaShape (OneOfTagged _) = "oneof-tagged"++-- | Check if constructor shapes are mutually exclusive (distinguishable)+areShapesDistinguishable :: [ConstructorSchema] -> Bool+areShapesDistinguishable constructors =+  let shapes = map (schemaShape . csPayload) constructors+      uniqueShapes = nub shapes+  in length shapes == length uniqueShapes++-- | Choose appropriate sum type encoding based on constructor analysis+chooseSumEncoding :: [ConstructorSchema] -> Schema+chooseSumEncoding constructors+  | null constructors = Null'  -- Shouldn't happen, but handle gracefully+  | isEnum constructors = Enum' (map csName constructors)+  | areShapesDistinguishable constructors = OneOfUntagged constructors+  | otherwise = OneOfTagged constructors++instance (HasFunctionObject s) => GSchema s U1 where   gschema _ = Null'  instance (HasFunctionObject s, JSONSchema c) => GSchema s (K1 i c) where@@ -437,17 +533,39 @@ instance (HasFunctionObject s, GSchema s a, GSchema s b) => GSchema s (a :*: b) where   gschema _ = gschema @s @a undefined <> gschema @s @b undefined +-- | Sum type instance - collects all constructors from both branches instance (HasFunctionObject s, GSchema s a, GSchema s b) => GSchema s (a :+: b) where-  gschema _ = gschema @s @a undefined-  gschema _ = gschema @s @b undefined+  gschema _ =+    let leftSchema = gschema @s @a undefined+        rightSchema = gschema @s @b undefined+        leftConstructors = extractConstructors leftSchema+        rightConstructors = extractConstructors rightSchema+        allConstructors = leftConstructors ++ rightConstructors+    in chooseSumEncoding allConstructors --- | Datatype+-- | Datatype - unwraps single-constructor types to their payload instance (HasFunctionObject s, GSchema s f) => GSchema s (M1 D c f) where-  gschema _ = gschema @s @f undefined+  gschema _ =+    let innerSchema = gschema @s @f undefined+    in case innerSchema of+         -- Single constructor case: unwrap to just the payload+         Enum' [_] -> Null'  -- Single nullary constructor is just Null+         OneOfUntagged [ConstructorSchema _ payload _] -> payload+         -- Multiple constructors: keep as-is+         _ -> innerSchema --- | Constructor Metadata+-- | Constructor Metadata - captures constructor name and wraps payload instance (HasFunctionObject s, GSchema s f, Constructor c) => GSchema s (M1 C c f) where-  gschema _ = gschema @s @f undefined+  gschema proxy =+    let name = T.pack $ conName (undefined :: M1 C c f p)+        normalizedName = normalizeConstructorName name+        payload = gschema @s @f undefined+        isNullary = isNullarySchema payload+    -- Return a single-constructor "sum type" that will be collected by :+:+    -- or used directly if there's only one constructor+    in case payload of+         Null' -> Enum' [normalizedName]  -- Nullary constructor+         _ -> OneOfUntagged [ConstructorSchema normalizedName payload isNullary]  -- | Selector Metadata instance (HasFunctionObject s, GSchema s f, Selector c) => GSchema s (M1 S c f) where@@ -456,13 +574,13 @@         desc = getFieldDescription @s name      in Object' [(name, desc, (gschema @s @f undefined))] -toolAdd :: forall api a. (LLMApi api, Tool a, HasFunctionObject a, JSONSchema a) => LLMRequest' api -> LLMRequest' api+toolAdd :: forall a. (Tool a, HasFunctionObject a, JSONSchema a) => Louter.ChatRequest -> Louter.ChatRequest toolAdd req =-  let prevTools = case toTools @api req of+  let prevTools = case toTools req of         [] -> []         v -> v-      newTools = prevTools ++ [newTool @api @a Proxy]-   in fromTools @api req newTools+      newTools = prevTools ++ [newTool @a Proxy]+   in fromTools req newTools  defaultUTCTime :: UTCTime defaultUTCTime = UTCTime (coerce (0 :: Integer)) 0@@ -530,33 +648,38 @@   deleteKey :: (MonadIO m, MonadFail m) => Conn p -> Unique KeyValue -> m ()  -instance LLMApi OpenAI where-  type LLMRequest' OpenAI = Louter.ChatRequest-  type LLMResponse' OpenAI = Louter.ChatResponse-  type LLMTool' OpenAI = Louter.Tool-  defaultRequest =-    Louter.ChatRequest-      { Louter.reqModel = "gpt-4"-      , Louter.reqMessages = []-      , Louter.reqTools = []-      , Louter.reqToolChoice = Louter.ToolChoiceAuto-      , Louter.reqTemperature = Nothing-      , Louter.reqMaxTokens = Nothing-      , Louter.reqStream = False-      }-  newTool (Proxy :: Proxy a) =-    Louter.Tool-      { Louter.toolName = T.pack $ getFunctionName @a-      , Louter.toolDescription = Just (T.pack $ getFunctionDescription @a)-      , Louter.toolParameters = toAeson (schema @a)-      }-  toTools req = Louter.reqTools req-  fromTools req tools = req { Louter.reqTools = tools }-  fromModel_ model =-    (defaultRequest @OpenAI :: LLMRequest' OpenAI)-      { Louter.reqModel = model-      }+defaultRequest :: Louter.ChatRequest+defaultRequest =+  Louter.ChatRequest+    { Louter.reqModel = "gpt-4"+    , Louter.reqMessages = []+    , Louter.reqTools = []+    , Louter.reqToolChoice = Louter.ToolChoiceAuto+    , Louter.reqTemperature = Nothing+    , Louter.reqMaxTokens = Nothing+    , Louter.reqStream = False+    } +newTool :: forall a. (HasFunctionObject a, JSONSchema a) => Proxy a -> Louter.Tool+newTool (Proxy :: Proxy a) =+  Louter.Tool+    { Louter.toolName = T.pack $ getFunctionName @a+    , Louter.toolDescription = Just (T.pack $ getFunctionDescription @a)+    , Louter.toolParameters = toAeson (schema @a)+    }++toTools :: Louter.ChatRequest -> [Louter.Tool]+toTools req = Louter.reqTools req++fromTools :: Louter.ChatRequest -> [Louter.Tool] -> Louter.ChatRequest+fromTools req tools = req { Louter.reqTools = tools }++fromModel_ :: Text -> Louter.ChatRequest+fromModel_ model =+  (defaultRequest :: Louter.ChatRequest)+    { Louter.reqModel = model+    }+ -- | Read the JSON object and convert it to a Map toMap :: Text -> Map Text Value toMap json =@@ -569,7 +692,7 @@ fromMap txt = TL.toStrict $ A.encodeToLazyText txt  instance ChatCompletion Contents where-  toRequest (LouterRequest orgRequest) contents =+  toRequest orgRequest contents =     let messages = flip map contents $ \case           Content user (Message message) _ _ ->             Louter.Message@@ -600,9 +723,9 @@               { Louter.msgRole = Louter.RoleTool               , Louter.msgContent = [Louter.TextPart ret']               }-     in LouterRequest $ orgRequest { Louter.reqMessages = messages }+     in orgRequest { Louter.reqMessages = messages } -  fromResponse sessionName (LouterResponse response) =+  fromResponse sessionName response =     let choice = head (Louter.respChoices response)         message = Louter.choiceMessage choice         toolCalls = Louter.choiceToolCalls choice@@ -624,41 +747,21 @@      in (contents, finishReason)      -data LLMProxy api =-  LLMProxy-  { toRequest' :: LLMRequest' api -> LLMRequest-  , toResponse' :: LLMResponse' api -> LLMResponse-  }--withLLMRequest-  :: forall a. LLMRequest-  -> (forall (api :: Type)-      . (LLMApi api)-      => LLMProxy api-      -> LLMRequest' api-      -> a)-  -> a-withLLMRequest req func =-  case req of-    LouterRequest req' -> func (LLMProxy @OpenAI LouterRequest LouterResponse) req'--updateRequest :: LLMRequest -> Contents -> LLMRequest+updateRequest :: Louter.ChatRequest -> Contents -> Louter.ChatRequest updateRequest = toRequest ---  withLLMRequest req' $ \(p :: LLMProxy api) req -> (toRequest' @api p) (toRequest req cs)--addTools :: [ToolProxy] -> LLMRequest -> LLMRequest+addTools :: [ToolProxy] -> Louter.ChatRequest -> Louter.ChatRequest addTools [] req' = req' addTools (tool : tools') req' =   case tool of     (ToolProxy (_ :: Proxy a)) ->-      withLLMRequest req' $ \(p :: LLMProxy api) req -> addTools tools' ((toRequest' @api p) $ toolAdd @api @a req)-      -fromModel :: Text -> LLMRequest-fromModel = LouterRequest . fromModel_ @OpenAI+      addTools tools' (toolAdd @a req') -runRequest :: forall a. (ChatCompletion a) => Text -> LLMRequest -> a -> IO ((a, FinishReason), LLMResponse)-runRequest sessionName (LouterRequest defaultReq) request = do+fromModel :: Text -> Louter.ChatRequest+fromModel = fromModel_++runRequest :: forall a. (ChatCompletion a) => Text -> Louter.ChatRequest -> a -> IO ((a, FinishReason), Louter.ChatResponse)+runRequest sessionName defaultReq request = do   config <- readConfig    -- Determine backend type (default to OpenAI if not specified)@@ -684,7 +787,7 @@           }    client <- Louter.newClient louterBackend-  let (LouterRequest req) = (toRequest (LouterRequest defaultReq) request)+  let req = toRequest defaultReq request    lookupEnv "OPENAI_DEBUG" >>= \case     Just "1" -> do@@ -696,4 +799,4 @@   result <- Louter.chatCompletion client req   case result of     Left err -> error $ T.unpack $ "Louter error: " <> err-    Right res -> return $ (fromResponse sessionName (LouterResponse res), LouterResponse res)+    Right res -> return $ (fromResponse sessionName res, res)
+ test/ArxivSpec.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE OverloadedStrings #-}++module ArxivSpec (spec) where++import IntelliMonad.Tools.Arxiv+import IntelliMonad.Types+import IntelliMonad.Prompt+import IntelliMonad.Persist+import Test.Hspec++spec :: Spec+spec = do+  describe "Arxiv Tool" $ do+    describe "Schema Generation" $ do+      it "generates correct JSON schema" $ do+        let arxivSchema = schema @Arxiv+        case arxivSchema of+          Object' fields -> do+            length fields `shouldBe` 3+            -- Check that all expected fields are present+            let fieldNames = map (\(name, _, _) -> name) fields+            fieldNames `shouldContain` ["searchQuery"]+            fieldNames `shouldContain` ["maxResults"]+            fieldNames `shouldContain` ["start"]+          _ -> expectationFailure "Expected Object' schema"++    describe "Real API Request" $ do+      it "makes successful request to Arxiv API and retrieves papers" $ do+        -- Create Arxiv query+        let arxivQuery = Arxiv+              { searchQuery = "quantum computing"+              , maxResults = Just 3+              , start = Just 0+              }++        -- Run toolExec in the Prompt monad using runPrompt like calc.hs does+        result <- runPrompt @StatelessConf [] [] "test-session" (defaultRequest) $ do+          toolExec @Arxiv @StatelessConf arxivQuery++        -- Verify results+        length (papers result) `shouldSatisfy` (> 0)+        length (papers result) `shouldSatisfy` (<= 3)++        -- Verify first paper has required fields+        case papers result of+          (firstPaper:_) -> do+            arxivId firstPaper `shouldSatisfy` (not . null . show)+            title firstPaper `shouldSatisfy` (not . null . show)+            summary firstPaper `shouldSatisfy` (not . null . show)+            published firstPaper `shouldSatisfy` (not . null . show)+          [] -> expectationFailure "No papers returned"++      it "handles different search queries" $ do+        let arxivQuery = Arxiv+              { searchQuery = "neural networks"+              , maxResults = Just 2+              , start = Just 0+              }++        -- Run toolExec using runPrompt+        result <- runPrompt @StatelessConf [] [] "test-session" (defaultRequest) $ do+          toolExec @Arxiv @StatelessConf arxivQuery++        length (papers result) `shouldSatisfy` (> 0)+        length (papers result) `shouldSatisfy` (<= 2)
− test/Main.hs 
@@ -1,4 +0,0 @@-module Main (main) where--main :: IO ()-main = putStrLn "Test suite not yet implemented."
+ test/Spec.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}++module Main (main) where++import Data.Aeson (Value, encode)+import qualified Data.Aeson as A+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KM+import qualified Data.Text.Encoding as TE+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Vector as V+import GHC.Generics+import IntelliMonad.Types+import Test.Hspec+import qualified Data.ByteString.Lazy as BL+import qualified ArxivSpec++-- Test types for enum (all nullary constructors)+data Color = Red | Green | Blue+  deriving (Eq, Show, Generic)++instance HasFunctionObject Color where+  getFunctionName = "set_color"+  getFunctionDescription = "Set the color"+  getFieldDescription _ = ""++instance JSONSchema Color++-- Test types for untagged sum type (distinguishable shapes)+data Result+  = Success { code :: Int }+  | Error { message :: String }+  deriving (Eq, Show, Generic)++instance JSONSchema Result++instance HasFunctionObject Result where+  getFunctionName = "get_result"+  getFunctionDescription = "Get operation result"+  getFieldDescription "code" = "Success code"+  getFieldDescription "message" = "Error message"+  getFieldDescription _ = ""++-- Test types for tagged sum type (overlapping shapes)+data ValueType+  = IntVal Int+  | StrVal String+  deriving (Eq, Show, Generic)++instance JSONSchema ValueType++instance HasFunctionObject ValueType where+  getFunctionName = "set_value"+  getFunctionDescription = "Set a value"+  getFieldDescription _ = ""++-- Test mixed nullary and payload constructors+data Status+  = Pending+  | InProgress { percentage :: Int }+  | Completed+  | Failed { reason :: String }+  deriving (Eq, Show, Generic)++instance JSONSchema Status++instance HasFunctionObject Status where+  getFunctionName = "set_status"+  getFunctionDescription = "Set operation status"+  getFieldDescription "percentage" = "Completion percentage"+  getFieldDescription "reason" = "Failure reason"+  getFieldDescription _ = ""++-- Helper to pretty print JSON+prettyJSON :: Value -> String+prettyJSON = T.unpack . TE.decodeUtf8 . BL.toStrict . encode++main :: IO ()+main = hspec $ do+  -- Run Arxiv tool tests+  ArxivSpec.spec++  describe "JSON Schema Generation for Sum Types" $ do++    describe "Enum type (all nullary constructors)" $ do+      it "generates string enum schema" $ do+        let s = schema @Color+        let json = toAeson s+        putStrLn $ "\nColor schema: " ++ prettyJSON json+        -- Should be: {"type": "string", "enum": ["red", "green", "blue"]}+        case json of+          A.Object obj -> do+            KM.lookup (Key.fromString "type") obj `shouldBe` Just (A.String $ T.pack "string")+            case KM.lookup (Key.fromString "enum") obj of+              Just (A.Array arr) -> V.length arr `shouldBe` 3+              _ -> expectationFailure "Missing enum array"+          _ -> expectationFailure "Expected object schema"++    describe "Untagged sum type (distinguishable shapes)" $ do+      it "generates oneOf schema with distinct object schemas" $ do+        let s = schema @Result+        let json = toAeson s+        putStrLn $ "\nResult schema: " ++ prettyJSON json+        -- Should have oneOf with two different object schemas+        case json of+          A.Object obj -> do+            case KM.lookup (Key.fromString "oneOf") obj of+              Just (A.Array arr) -> V.length arr `shouldBe` 2+              _ -> expectationFailure "Missing oneOf array"+          _ -> expectationFailure "Expected object schema"++    describe "Tagged sum type (overlapping shapes)" $ do+      it "generates oneOf schema with @tag/@value" $ do+        let s = schema @ValueType+        let json = toAeson s+        putStrLn $ "\nValueType schema: " ++ prettyJSON json+        -- Should have oneOf with @tag/@value schemas+        case json of+          A.Object obj -> do+            case KM.lookup (Key.fromString "oneOf") obj of+              Just (A.Array arr) -> do+                V.length arr `shouldBe` 2+                -- Check that first variant has @tag field+                case arr V.!? 0 of+                  Just (A.Object variantObj) -> do+                    case KM.lookup (Key.fromString "properties") variantObj of+                      Just (A.Object props) -> do+                        KM.lookup (Key.fromString "@tag") props `shouldSatisfy` (/= Nothing)+                      _ -> expectationFailure "Missing properties"+                  _ -> expectationFailure "Expected object variant"+              _ -> expectationFailure "Missing oneOf array"+          _ -> expectationFailure "Expected object schema"++    describe "Mixed nullary and payload constructors" $ do+      it "generates oneOf schema with mixed types" $ do+        let s = schema @Status+        let json = toAeson s+        putStrLn $ "\nStatus schema: " ++ prettyJSON json+        -- Should have oneOf with 4 variants+        case json of+          A.Object obj -> do+            case KM.lookup (Key.fromString "oneOf") obj of+              Just (A.Array arr) -> V.length arr `shouldBe` 4+              _ -> expectationFailure "Missing oneOf array"+          _ -> expectationFailure "Expected object schema"++    describe "Round-trip encoding" $ do+      it "schema can be encoded to JSON and is valid" $ do+        let colorSchema = toAeson $ schema @Color+        let resultSchema = toAeson $ schema @Result+        let valueSchema = toAeson $ schema @ValueType++        -- Just check they encode without errors+        encode colorSchema `shouldSatisfy` (\bs -> BL.length bs > 0)+        encode resultSchema `shouldSatisfy` (\bs -> BL.length bs > 0)+        encode valueSchema `shouldSatisfy` (\bs -> BL.length bs > 0)