diff --git a/intelli-monad.cabal b/intelli-monad.cabal --- a/intelli-monad.cabal +++ b/intelli-monad.cabal @@ -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 diff --git a/src/IntelliMonad/Cmd.hs b/src/IntelliMonad/Cmd.hs --- a/src/IntelliMonad/Cmd.hs +++ b/src/IntelliMonad/Cmd.hs @@ -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, diff --git a/src/IntelliMonad/CustomInstructions.hs b/src/IntelliMonad/CustomInstructions.hs --- a/src/IntelliMonad/CustomInstructions.hs +++ b/src/IntelliMonad/CustomInstructions.hs @@ -24,7 +24,6 @@ import Data.Proxy import GHC.Generics import IntelliMonad.Types -import qualified OpenAI.Types as API defaultCustomInstructions :: [CustomInstructionProxy] defaultCustomInstructions = [] diff --git a/src/IntelliMonad/Prompt.hs b/src/IntelliMonad/Prompt.hs --- a/src/IntelliMonad/Prompt.hs +++ b/src/IntelliMonad/Prompt.hs @@ -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 diff --git a/src/IntelliMonad/Repl.hs b/src/IntelliMonad/Repl.hs --- a/src/IntelliMonad/Repl.hs +++ b/src/IntelliMonad/Repl.hs @@ -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 diff --git a/src/IntelliMonad/Tools.hs b/src/IntelliMonad/Tools.hs --- a/src/IntelliMonad/Tools.hs +++ b/src/IntelliMonad/Tools.hs @@ -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 = diff --git a/src/IntelliMonad/Tools/Arxiv.hs b/src/IntelliMonad/Tools/Arxiv.hs --- a/src/IntelliMonad/Tools/Arxiv.hs +++ b/src/IntelliMonad/Tools/Arxiv.hs @@ -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, ($//), (&/), (&//)) diff --git a/src/IntelliMonad/Tools/Bash.hs b/src/IntelliMonad/Tools/Bash.hs --- a/src/IntelliMonad/Tools/Bash.hs +++ b/src/IntelliMonad/Tools/Bash.hs @@ -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 diff --git a/src/IntelliMonad/Tools/DallE3.hs b/src/IntelliMonad/Tools/DallE3.hs deleted file mode 100644 --- a/src/IntelliMonad/Tools/DallE3.hs +++ /dev/null @@ -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' diff --git a/src/IntelliMonad/Tools/KeyValue.hs b/src/IntelliMonad/Tools/KeyValue.hs --- a/src/IntelliMonad/Tools/KeyValue.hs +++ b/src/IntelliMonad/Tools/KeyValue.hs @@ -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 diff --git a/src/IntelliMonad/Tools/TextToSpeech.hs b/src/IntelliMonad/Tools/TextToSpeech.hs deleted file mode 100644 --- a/src/IntelliMonad/Tools/TextToSpeech.hs +++ /dev/null @@ -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 diff --git a/src/IntelliMonad/Tools/Utils.hs b/src/IntelliMonad/Tools/Utils.hs --- a/src/IntelliMonad/Tools/Utils.hs +++ b/src/IntelliMonad/Tools/Utils.hs @@ -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. diff --git a/src/IntelliMonad/Types.hs b/src/IntelliMonad/Types.hs --- a/src/IntelliMonad/Types.hs +++ b/src/IntelliMonad/Types.hs @@ -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) diff --git a/test/ArxivSpec.hs b/test/ArxivSpec.hs new file mode 100644 --- /dev/null +++ b/test/ArxivSpec.hs @@ -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) diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 --- a/test/Main.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main (main) where - -main :: IO () -main = putStrLn "Test suite not yet implemented." diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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)