diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -114,3 +114,17 @@ v <- runPromptWithValidation @ValidateNumber @StatelessConf [] [CustomInstructionProxy (Proxy @Math)] "default" (fromModel "gpt-4") "2+3+3+sin(3)" print (v :: Maybe ValidateNumber) ``` + +# Configuration + +To specify OpenAI endpoints and models as part of data instead of using environment variables, you can use a configuration file. Create a `intellimonad-config.yaml` file in the root directory of your project with the following content: + +```yaml +apiKey: "your_openai_api_key" +endpoint: "https://api.openai.com/v1/" +model: "gpt-4" +``` + +The `apiKey` is your OpenAI API key, `endpoint` is the OpenAI endpoint, and `model` is the model you want to use. + +Make sure to update the `initializePrompt` and `runPrompt` functions to read from the configuration file as shown in the examples in the `intelli-monad/app/auto-talk.hs` and `intelli-monad/app/calc.hs` files. diff --git a/app/auto-talk.hs b/app/auto-talk.hs --- a/app/auto-talk.hs +++ b/app/auto-talk.hs @@ -5,6 +5,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedRecordDot #-} module Main where @@ -13,6 +14,7 @@ import IntelliMonad.Persist import IntelliMonad.Prompt import IntelliMonad.Types +import IntelliMonad.Config data Haruhi = Haruhi @@ -40,9 +42,10 @@ main :: IO () main = do - e <- initializePrompt @StatelessConf [] [CustomInstructionProxy Env]"env" (fromModel "gpt-4") - h <- initializePrompt @StatelessConf [] [CustomInstructionProxy Haruhi] "haruhi" (fromModel "gpt-4") - k <- initializePrompt @StatelessConf [] [CustomInstructionProxy Kyon] "kyon" (fromModel "gpt-4") + config <- readConfig + e <- initializePrompt @StatelessConf [] [CustomInstructionProxy Env] "env" (fromModel config.model) + h <- initializePrompt @StatelessConf [] [CustomInstructionProxy Haruhi] "haruhi" (fromModel config.model) + k <- initializePrompt @StatelessConf [] [CustomInstructionProxy Kyon] "kyon" (fromModel config.model) let init' = [Content User (Message "ある駄菓子屋の前での出来ことで話を作ってください。Let's start!") "default" defaultUTCTime] loop init' [] [] [] e h k where diff --git a/app/calc.hs b/app/calc.hs --- a/app/calc.hs +++ b/app/calc.hs @@ -6,6 +6,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} module Main where @@ -16,7 +17,7 @@ import IntelliMonad.Persist import IntelliMonad.Prompt import IntelliMonad.Types -import OpenAI.Types +import IntelliMonad.Config data ValidateNumber = ValidateNumber { number :: Double @@ -70,7 +71,8 @@ main :: IO () main = do - v <- runPromptWithValidation @ValidateNumber @StatelessConf [] [] "default" (fromModel "gpt-4") "2+3+3+sin(3)" + config <- readConfig + v <- runPromptWithValidation @ValidateNumber @StatelessConf [] [] "default" (fromModel config.model) "2+3+3+sin(3)" print (v :: Maybe ValidateNumber) v <- generate [user "Calcurate a formula"] (Input "1+3") diff --git a/intelli-monad.cabal b/intelli-monad.cabal --- a/intelli-monad.cabal +++ b/intelli-monad.cabal @@ -1,8 +1,8 @@ cabal-version: 3.0 name: intelli-monad -version: 0.1.0.2 -synopsis: Type level prompt with openai. -description: Type level prompt with openai. This allows us to define function calls and value validation using types. +version: 0.1.1.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 license: MIT @@ -47,6 +47,7 @@ , IntelliMonad.Persist , IntelliMonad.Repl , IntelliMonad.Cmd + , IntelliMonad.Config , IntelliMonad.CustomInstructions -- Modules included in this library but not exported. @@ -56,16 +57,17 @@ -- other-extensions: -- Other library packages from which modules are imported. - build-depends: base ==4.* + build-depends: base >= 4.0 && < 5.0 , JuicyPixels >= 3.3.8 && < 3.4 - , bytestring >= 0.11.5 && < 0.12 + , bytestring >= 0.11.5 && < 0.13 , containers >= 0.6.7 && < 0.7 , transformers >= 0.6.1 && < 0.7 , vector >= 0.13.1 && < 0.14 , aeson >= 2.1 && < 2.3 - , text >= 2.0.2 && < 2.1 + , text >= 2.0.2 && < 2.2 , time >= 1.12.2 && < 1.13 , aeson-pretty >= 0.8.10 && < 0.9 + , aeson-casing >= 0.2 && < 0.3 , process >= 1.6.17 && < 1.7 , base64-bytestring >= 1.2.1 && < 1.3 , haskeline >= 0.8.2 && < 0.9 @@ -73,8 +75,9 @@ , http-client-tls >= 0.3.6 && < 0.4 , 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.21 + , 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 @@ -83,6 +86,16 @@ , temporary >= 1.3 && < 1.4 , xml-conduit >= 1.9 && < 2.0 , 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 + , wai-extra >=3.1 && <3.2 + , stm >=2.5 && <2.6 + , kan-extensions >=5.2 && <5.3 + , http-types >=0.12 && <1.0 -- Directories containing source files. hs-source-dirs: src @@ -92,10 +105,11 @@ executable intelli-monad import: warnings main-is: repl.hs + ghc-options: -rtsopts -threaded -g build-depends: base == 4.*, intelli-monad, - openai-servant-gen, + louter, text, process, persistent-sqlite @@ -108,7 +122,7 @@ build-depends: base == 4.*, intelli-monad, - openai-servant-gen, + louter, text, aeson hs-source-dirs: app @@ -120,13 +134,13 @@ build-depends: base == 4.*, intelli-monad, - openai-servant-gen, + louter, text, aeson, transformers hs-source-dirs: app default-language: Haskell2010 - + test-suite intelli-monad-test -- Import common warning flags. import: warnings diff --git a/src/IntelliMonad/Cmd.hs b/src/IntelliMonad/Cmd.hs --- a/src/IntelliMonad/Cmd.hs +++ b/src/IntelliMonad/Cmd.hs @@ -29,6 +29,7 @@ import Data.Void import Database.Persist.Sqlite (SqliteConf) import GHC.IO.Exception +import IntelliMonad.Config import IntelliMonad.Persist import IntelliMonad.Prompt import IntelliMonad.Repl @@ -75,13 +76,11 @@ runCmd :: forall p. (PersistentBackend p) => ReplCommand -> IO () runCmd cmd = do + config <- readConfig let tools = defaultTools customs = [] sessionName = "default" - defaultReq = - defaultRequest - { API.createChatCompletionRequestModel = API.CreateChatCompletionRequestModel "gpt-4" - } + defaultReq = LouterRequest (defaultRequest @OpenAI) runInputT ( Settings { complete = completeFilename, @@ -89,7 +88,7 @@ autoAddHistory = True } ) - (runPrompt @p tools customs sessionName defaultReq (runCmd' @p (Right cmd) Nothing)) + (runPrompt @p [] customs sessionName defaultReq (runCmd' @p (Right cmd) Nothing)) main :: IO () main = do diff --git a/src/IntelliMonad/Config.hs b/src/IntelliMonad/Config.hs new file mode 100644 --- /dev/null +++ b/src/IntelliMonad/Config.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module IntelliMonad.Config where + +import Data.Yaml +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) + +-- | Backend type: openai, anthropic, or gemini +data BackendType = OpenAI | Anthropic | Gemini + deriving (Show, Eq, Generic) + +instance FromJSON BackendType where + parseJSON = withText "BackendType" $ \t -> case T.toLower t of + "openai" -> pure OpenAI + "anthropic" -> pure Anthropic + "gemini" -> pure Gemini + other -> fail $ "Unknown backend type: " <> T.unpack other <> ". Must be one of: openai, anthropic, gemini" + +instance ToJSON BackendType where + toJSON OpenAI = String "openai" + toJSON Anthropic = String "anthropic" + toJSON Gemini = String "gemini" + +data Config = Config + { apiKey :: Text + , endpoint :: Text + , model :: Text + , backend :: Maybe BackendType -- Optional, defaults to openai + } deriving (Show, Generic) + +instance FromJSON Config + +readConfig :: IO Config +readConfig = do + config <- decodeFileEither "intellimonad-config.yaml" + case config of + Left err -> error $ "Error reading config file: " ++ show err + Right cfg -> return cfg diff --git a/src/IntelliMonad/Prompt.hs b/src/IntelliMonad/Prompt.hs --- a/src/IntelliMonad/Prompt.hs +++ b/src/IntelliMonad/Prompt.hs @@ -32,6 +32,7 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import Data.Time +import IntelliMonad.Config import IntelliMonad.CustomInstructions import IntelliMonad.Persist import IntelliMonad.Tools @@ -69,7 +70,7 @@ next = prev { contextBody = nextContents, - contextRequest = toRequest prev.contextRequest (prev.contextHeader <> nextContents <> prev.contextFooter) + contextRequest = updateRequest prev.contextRequest (prev.contextHeader <> nextContents <> prev.contextFooter) } setContext @p next @@ -96,7 +97,7 @@ next = prev { contextBody = nextContents, - contextRequest = toRequest prev.contextRequest (prev.contextHeader <> nextContents <> prev.contextFooter) + contextRequest = updateRequest prev.contextRequest (prev.contextHeader <> nextContents <> prev.contextFooter) } setContext @p next @@ -123,7 +124,7 @@ callPreHook @p prev <- getContext ((contents, finishReason), res) <- liftIO $ runRequest prev.contextSessionName prev.contextRequest (prev.contextHeader <> prev.contextBody <> prev.contextFooter) - let current_total_tokens = fromMaybe 0 $ API.completionUsageTotalUnderscoretokens <$> API.createChatCompletionResponseUsage res + let current_total_tokens = 0 -- fromMaybe 0 $ API.completionUsageTotalUnderscoretokens <$> API.createChatCompletionResponseUsage res next = prev { contextResponse = Just res, @@ -173,7 +174,9 @@ A.FromJSON validation, A.FromJSON (Output validation), A.ToJSON validation, - A.ToJSON (Output validation) + A.ToJSON (Output validation), + HasFunctionObject validation, + JSONSchema validation ) => Contents -> Prompt m (Maybe validation) @@ -198,12 +201,14 @@ A.FromJSON validation, A.FromJSON (Output validation), A.ToJSON validation, - A.ToJSON (Output validation) + A.ToJSON (Output validation), + HasFunctionObject validation, + JSONSchema validation ) => [ToolProxy] -> [CustomInstructionProxy] -> Text -> - API.CreateChatCompletionRequest -> + LLMRequest -> Text -> m (Maybe validation) runPromptWithValidation tools customs sessionName req input = do @@ -231,7 +236,9 @@ A.FromJSON output, A.FromJSON (Output output), A.ToJSON output, - A.ToJSON (Output output) + A.ToJSON (Output output), + HasFunctionObject output, + JSONSchema output ) => Contents -> input -> m (Maybe output) generate userContext input = do let valid = ToolProxy (Proxy :: Proxy output) @@ -252,9 +259,10 @@ push @p contents call @p >>= callWithValidation @output @StatelessConf -initializePrompt :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => [ToolProxy] -> [CustomInstructionProxy] -> Text -> API.CreateChatCompletionRequest -> m PromptEnv +initializePrompt :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => [ToolProxy] -> [CustomInstructionProxy] -> Text -> LLMRequest -> m PromptEnv initializePrompt tools customs sessionName req = do - let settings = addTools tools (req {API.createChatCompletionRequestTools = Nothing}) +-- config <- readConfig + let settings = addTools tools req withDB @p $ \conn -> do load @p conn sessionName >>= \case Just v -> @@ -289,112 +297,11 @@ initialize @p conn (init'.context) return init' -runPrompt :: forall p m a. (MonadIO m, MonadFail m, PersistentBackend p) => [ToolProxy] -> [CustomInstructionProxy] -> Text -> API.CreateChatCompletionRequest -> Prompt m a -> m a +runPrompt :: forall p m a. (MonadIO m, MonadFail m, PersistentBackend p) => [ToolProxy] -> [CustomInstructionProxy] -> Text -> LLMRequest -> Prompt m a -> m a runPrompt tools customs sessionName req func = do context <- initializePrompt @p tools customs sessionName req fst <$> runStateT func context -instance ChatCompletion Contents where - toRequest orgRequest contents = - let messages = flip map contents $ \case - Content user (Message message) _ _ -> - API.ChatCompletionRequestMessage - { API.chatCompletionRequestMessageContent = Just $ API.ChatCompletionRequestMessageContentText message, - API.chatCompletionRequestMessageRole = userToText user, - API.chatCompletionRequestMessageName = Nothing, - API.chatCompletionRequestMessageToolUnderscorecalls = Nothing, - API.chatCompletionRequestMessageFunctionUnderscorecall = Nothing, - API.chatCompletionRequestMessageToolUnderscorecallUnderscoreid = Nothing - } - Content user (Image type' img) _ _ -> - API.ChatCompletionRequestMessage - { API.chatCompletionRequestMessageContent = - Just $ - API.ChatCompletionRequestMessageContentParts - [ API.ChatCompletionRequestMessageContentPart - { API.chatCompletionRequestMessageContentPartType = "image_url", - API.chatCompletionRequestMessageContentPartText = Nothing, - API.chatCompletionRequestMessageContentPartImageUnderscoreurl = - Just $ - API.ChatCompletionRequestMessageContentPartImageImageUrl - { API.chatCompletionRequestMessageContentPartImageImageUrlUrl = - "data:image/" <> type' <> ";base64," <> img, - API.chatCompletionRequestMessageContentPartImageImageUrlDetail = Nothing - } - } - ], - API.chatCompletionRequestMessageRole = userToText user, - API.chatCompletionRequestMessageName = Nothing, - API.chatCompletionRequestMessageToolUnderscorecalls = Nothing, - API.chatCompletionRequestMessageFunctionUnderscorecall = Nothing, - API.chatCompletionRequestMessageToolUnderscorecallUnderscoreid = Nothing - } - Content user (ToolCall id' name' args') _ _ -> - API.ChatCompletionRequestMessage - { API.chatCompletionRequestMessageContent = Nothing, - API.chatCompletionRequestMessageRole = userToText user, - API.chatCompletionRequestMessageName = Nothing, - API.chatCompletionRequestMessageToolUnderscorecalls = - Just - [ API.ChatCompletionMessageToolCall - { API.chatCompletionMessageToolCallId = id', - API.chatCompletionMessageToolCallType = "function", - API.chatCompletionMessageToolCallFunction = - API.ChatCompletionMessageToolCallFunction - { API.chatCompletionMessageToolCallFunctionName = name', - API.chatCompletionMessageToolCallFunctionArguments = args' - } - } - ], - API.chatCompletionRequestMessageFunctionUnderscorecall = Nothing, - API.chatCompletionRequestMessageToolUnderscorecallUnderscoreid = Just id' - } - Content user (ToolReturn id' name' ret') _ _ -> - API.ChatCompletionRequestMessage - { API.chatCompletionRequestMessageContent = Just $ API.ChatCompletionRequestMessageContentText ret', - API.chatCompletionRequestMessageRole = userToText user, - API.chatCompletionRequestMessageName = Just name', - API.chatCompletionRequestMessageToolUnderscorecalls = Nothing, - API.chatCompletionRequestMessageFunctionUnderscorecall = Nothing, - API.chatCompletionRequestMessageToolUnderscorecallUnderscoreid = Just id' - } - in orgRequest {API.createChatCompletionRequestMessages = messages} - fromResponse sessionName response = - let res = head (API.createChatCompletionResponseChoices response) - message = API.createChatCompletionResponseChoicesInnerMessage res - role = textToUser $ API.chatCompletionResponseMessageRole message - content = API.chatCompletionResponseMessageContent message - finishReason = textToFinishReason $ API.createChatCompletionResponseChoicesInnerFinishUnderscorereason res - v = case API.chatCompletionResponseMessageToolUnderscorecalls message of - Just toolcalls -> map (\(API.ChatCompletionMessageToolCall id' _ (API.ChatCompletionMessageToolCallFunction name' args')) -> Content role (ToolCall id' name' args') sessionName defaultUTCTime) toolcalls - Nothing -> [Content role (Message (fromMaybe "" content)) sessionName defaultUTCTime] - in (v, finishReason) - -runRequest :: (ChatCompletion a) => Text -> API.CreateChatCompletionRequest -> a -> IO ((a, FinishReason), API.CreateChatCompletionResponse) -runRequest sessionName defaultReq request = do - api_key <- (API.clientAuth . T.pack) <$> getEnv "OPENAI_API_KEY" - url <- do - lookupEnv "OPENAI_ENDPOINT" >>= \case - Just url -> parseBaseUrl url - Nothing -> parseBaseUrl "https://api.openai.com/v1/" - manager <- - newManager - ( tlsManagerSettings - { managerResponseTimeout = responseTimeoutMicro (120 * 1000 * 1000) - } - ) - let API.OpenAIBackend {..} = API.createOpenAIClient - req = (toRequest defaultReq request) - - lookupEnv "OPENAI_DEBUG" >>= \case - Just "1" -> do - liftIO $ do - BS.putStr $ BS.toStrict $ encodePretty req - T.putStrLn "" - _ -> return () - res <- API.callOpenAI (mkClientEnv manager url) $ createChatCompletion api_key req - return (fromResponse sessionName res, res) - showContents :: (MonadIO m) => Contents -> m () showContents res = do forM_ res $ \(Content user message _ _) -> @@ -407,12 +314,6 @@ Image _ _ -> "Image: ..." c@(ToolCall _ _ _) -> T.pack $ show c c@(ToolReturn _ _ _) -> T.pack $ show c - -fromModel :: Text -> API.CreateChatCompletionRequest -fromModel model = - defaultRequest - { API.createChatCompletionRequestModel = API.CreateChatCompletionRequestModel model - } clear :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => Prompt m () clear = do diff --git a/src/IntelliMonad/Repl.hs b/src/IntelliMonad/Repl.hs --- a/src/IntelliMonad/Repl.hs +++ b/src/IntelliMonad/Repl.hs @@ -42,6 +42,7 @@ import Text.Megaparsec import Text.Megaparsec.Char import Text.Megaparsec.Char.Lexer as L +import IntelliMonad.Config type Parser = Parsec Void Text @@ -106,7 +107,7 @@ ExitSuccess -> Just <$> T.readFile filePath ExitFailure _ -> return Nothing -editRequestWithEditor :: forall m. (MonadIO m, MonadFail m) => API.CreateChatCompletionRequest -> m (Maybe API.CreateChatCompletionRequest) +editRequestWithEditor :: forall m. (MonadIO m, MonadFail m) => LLMRequest -> m (Maybe LLMRequest) editRequestWithEditor req = do liftIO $ withSystemTempFile "tempfile.yaml" $ \filePath fileHandle -> do hClose fileHandle @@ -118,7 +119,7 @@ code <- system (editor <> " " <> filePath) case code of ExitSuccess -> do - newReq <- Y.decodeFileEither @API.CreateChatCompletionRequest filePath + newReq <- Y.decodeFileEither @LLMRequest filePath case newReq of Right newReq' -> return $ Just newReq' Left err -> do @@ -321,8 +322,9 @@ cmd <- getUserCommand @p runCmd' @p cmd (Just (runRepl' @p)) -runRepl :: forall p. (PersistentBackend p) => [ToolProxy] -> [CustomInstructionProxy] -> Text -> API.CreateChatCompletionRequest -> Contents -> IO () +runRepl :: forall p. (PersistentBackend p) => [ToolProxy] -> [CustomInstructionProxy] -> Text -> LLMRequest -> Contents -> IO () runRepl tools customs sessionName defaultReq contents = do + config <- readConfig runInputT ( Settings { complete = completeFilename, diff --git a/src/IntelliMonad/Tools/TextToSpeech.hs b/src/IntelliMonad/Tools/TextToSpeech.hs --- a/src/IntelliMonad/Tools/TextToSpeech.hs +++ b/src/IntelliMonad/Tools/TextToSpeech.hs @@ -8,6 +8,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedRecordDot #-} @@ -24,6 +25,7 @@ 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 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 @@ -32,12 +32,6 @@ import IntelliMonad.Types import qualified OpenAI.Types as API -addTools :: [ToolProxy] -> API.CreateChatCompletionRequest -> API.CreateChatCompletionRequest -addTools [] v = v -addTools (tool : tools') v = - case tool of - (ToolProxy (_ :: Proxy a)) -> addTools tools' (toolAdd @a v) - toolExec' :: forall t p m. (PersistentBackend p, MonadIO m, MonadFail m, Tool t, A.FromJSON t, A.ToJSON (Output t)) => diff --git a/src/IntelliMonad/Types.hs b/src/IntelliMonad/Types.hs --- a/src/IntelliMonad/Types.hs +++ b/src/IntelliMonad/Types.hs @@ -12,9 +12,11 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -33,24 +35,36 @@ import qualified Codec.Picture as P import Control.Monad.IO.Class import Control.Monad.Trans.State (StateT) -import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode) +import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode, Value) +import Data.Map (Map) import qualified Data.Aeson as A import qualified Data.Aeson.Key as A import qualified Data.Aeson.KeyMap as A +import qualified Data.Aeson.Text as A import Data.ByteString (ByteString, fromStrict, toStrict) import Data.Coerce import Data.Kind (Type) import qualified Data.Map as M import Data.Proxy import Data.Text (Text) +import Data.Maybe (fromMaybe) import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import Data.Time import qualified Data.Vector as V import Database.Persist import Database.Persist.Sqlite import Database.Persist.TH import GHC.Generics -import qualified OpenAI.Types as API +import qualified Louter.Client as Louter +import qualified Louter.Types.Request as Louter +import qualified Louter.Types.Response as Louter +import IntelliMonad.Config (readConfig) +import qualified IntelliMonad.Config as Config +import qualified Data.ByteString as BS +import qualified Data.Text.IO as T +import System.Environment (lookupEnv) +import Data.Aeson.Encode.Pretty (encodePretty) data User = User | System | Assistant | Tool deriving (Eq, Show, Ord, Generic) @@ -110,7 +124,7 @@ Length -> "length" ToolCalls -> "tool_calls" FunctionCall -> "function_call" - ContentFilter -> "content_fileter" + ContentFilter -> "content_filter" Null -> "null" textToFinishReason :: Text -> FinishReason @@ -129,13 +143,75 @@ newtype Model = Model Text deriving (Eq, Show) -class ChatCompletion a where - toRequest :: API.CreateChatCompletionRequest -> a -> API.CreateChatCompletionRequest - fromResponse :: Text -> API.CreateChatCompletionResponse -> (a, FinishReason) +class HasFunctionObject r where + getFunctionName :: String + getFunctionDescription :: String + getFieldDescription :: String -> String -class (ChatCompletion a) => Validate a b where - tryConvert :: a -> Either a b +data Schema + = Maybe' Schema + | String' + | Number' + | Integer' + | Object' [(String, String, Schema)] + | Array' Schema + | Boolean' + | Null' +class GSchema s f where + gschema :: forall a. f a -> Schema + +class JSONSchema r where + schema :: Schema + 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) + toPV :: (ToJSON a) => a -> PersistValue toPV = toPersistValue . toStrict . encode @@ -146,18 +222,18 @@ Right v -> return v Left err -> Left $ "Decoding JSON fails : " <> T.pack err -instance PersistField API.CreateChatCompletionRequest where +instance PersistField Louter.ChatRequest where toPersistValue = toPV fromPersistValue = fromPV -instance PersistFieldSql API.CreateChatCompletionRequest where +instance PersistFieldSql Louter.ChatRequest where sqlType _ = sqlType (Proxy @ByteString) -instance PersistField API.CreateChatCompletionResponse where +instance PersistField Louter.ChatResponse where toPersistValue = toPV fromPersistValue = fromPV -instance PersistFieldSql API.CreateChatCompletionResponse where +instance PersistFieldSql Louter.ChatResponse where sqlType _ = sqlType (Proxy @ByteString) instance PersistField User where @@ -174,6 +250,22 @@ 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| @@ -189,8 +281,8 @@ deriving FromJSON deriving Generic Context - request API.CreateChatCompletionRequest - response API.CreateChatCompletionResponse Maybe + request LLMRequest + response LLMResponse Maybe header [Content] body [Content] footer [Content] @@ -210,7 +302,7 @@ deriving Ord |] -data ToolProxy = forall t. (Tool t, A.FromJSON t, A.ToJSON t, A.FromJSON (Output t), A.ToJSON (Output t)) => ToolProxy (Proxy t) +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 customHeader :: a -> Contents @@ -247,31 +339,6 @@ type SessionName = Text -defaultRequest :: API.CreateChatCompletionRequest -defaultRequest = - API.CreateChatCompletionRequest - { API.createChatCompletionRequestMessages = [], - API.createChatCompletionRequestModel = API.CreateChatCompletionRequestModel "gpt-4", - API.createChatCompletionRequestFrequencyUnderscorepenalty = Nothing, - API.createChatCompletionRequestLogitUnderscorebias = Nothing, - API.createChatCompletionRequestLogprobs = Nothing, - API.createChatCompletionRequestTopUnderscorelogprobs = Nothing, - API.createChatCompletionRequestMaxUnderscoretokens = Nothing, - API.createChatCompletionRequestN = Nothing, - API.createChatCompletionRequestPresenceUnderscorepenalty = Nothing, - API.createChatCompletionRequestResponseUnderscoreformat = Nothing, - API.createChatCompletionRequestSeed = Just 0, - API.createChatCompletionRequestStop = Nothing, - API.createChatCompletionRequestStream = Nothing, - API.createChatCompletionRequestTemperature = Nothing, - API.createChatCompletionRequestTopUnderscorep = Nothing, - API.createChatCompletionRequestTools = Nothing, - API.createChatCompletionRequestToolUnderscorechoice = Nothing, - API.createChatCompletionRequestUser = Nothing, - API.createChatCompletionRequestFunctionUnderscorecall = Nothing, - API.createChatCompletionRequestFunctions = Nothing - } - class Tool a where data Output a :: Type @@ -279,10 +346,6 @@ default toolFunctionName :: (HasFunctionObject a) => Text toolFunctionName = T.pack $ getFunctionName @a - toolSchema :: API.ChatCompletionTool - default toolSchema :: (HasFunctionObject a, JSONSchema a, Generic a, GSchema a (Rep a)) => API.ChatCompletionTool - toolSchema = toChatCompletionTool @a - toolExec :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => a -> Prompt m (Output a) toolHeader :: Contents @@ -290,45 +353,6 @@ toolFooter :: Contents toolFooter = [] - -toChatCompletionTool :: forall a. (HasFunctionObject a, JSONSchema a) => API.ChatCompletionTool -toChatCompletionTool = - API.ChatCompletionTool - { chatCompletionToolType = "function", - chatCompletionToolFunction = - API.FunctionObject - { functionObjectDescription = Just (T.pack $ getFunctionDescription @a), - functionObjectName = T.pack $ getFunctionName @a, - functionObjectParameters = Just $ - case toAeson (schema @a) of - A.Object kv -> M.fromList $ map (\(k, v) -> (A.toString k, v)) $ A.toList kv - _ -> [] - } - } - -class HasFunctionObject r where - getFunctionName :: String - getFunctionDescription :: String - getFieldDescription :: String -> String - -class JSONSchema r where - schema :: Schema - default schema :: (HasFunctionObject r, Generic r, GSchema r (Rep r)) => Schema - schema = gschema @r (from (undefined :: r)) - -class GSchema s f where - gschema :: forall a. f a -> Schema - -data Schema - = Maybe' Schema - | String' - | Number' - | Integer' - | Object' [(String, String, Schema)] - | Array' Schema - | Boolean' - | Null' - toAeson :: Schema -> A.Value toAeson = \case Maybe' s -> toAeson s @@ -432,13 +456,13 @@ desc = getFieldDescription @s name in Object' [(name, desc, (gschema @s @f undefined))] -toolAdd :: forall a. (Tool a) => API.CreateChatCompletionRequest -> API.CreateChatCompletionRequest +toolAdd :: forall api a. (LLMApi api, Tool a, HasFunctionObject a, JSONSchema a) => LLMRequest' api -> LLMRequest' api toolAdd req = - let prevTools = case API.createChatCompletionRequestTools req of - Nothing -> [] - Just v -> v - newTools = prevTools ++ [toolSchema @a] - in req {API.createChatCompletionRequestTools = Just newTools} + let prevTools = case toTools @api req of + [] -> [] + v -> v + newTools = prevTools ++ [newTool @api @a Proxy] + in fromTools @api req newTools defaultUTCTime :: UTCTime defaultUTCTime = UTCTime (coerce (0 :: Integer)) 0 @@ -504,3 +528,172 @@ getKey :: (MonadIO m, MonadFail m) => Conn p -> Unique KeyValue -> m (Maybe Text) setKey :: (MonadIO m, MonadFail m) => Conn p -> Unique KeyValue -> Text -> m () 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 + } + +-- | Read the JSON object and convert it to a Map +toMap :: Text -> Map Text Value +toMap json = + case A.decodeStrictText json of + Just v -> v + Nothing -> error $ T.unpack $ "Decoding JSON fails" + + +fromMap :: Map Text Value -> Text +fromMap txt = TL.toStrict $ A.encodeToLazyText txt + +instance ChatCompletion Contents where + toRequest (LouterRequest orgRequest) contents = + let messages = flip map contents $ \case + Content user (Message message) _ _ -> + Louter.Message + { Louter.msgRole = case user of + User -> Louter.RoleUser + System -> Louter.RoleSystem + Assistant -> Louter.RoleAssistant + Tool -> Louter.RoleTool + , Louter.msgContent = [Louter.TextPart message] + } + Content user (Image type' img) _ _ -> + Louter.Message + { Louter.msgRole = case user of + User -> Louter.RoleUser + System -> Louter.RoleSystem + Assistant -> Louter.RoleAssistant + Tool -> Louter.RoleTool + , Louter.msgContent = [Louter.ImagePart type' img] + } + Content user (ToolCall id' name' args') _ _ -> + -- Tool calls need to be handled differently - for now, convert to text + Louter.Message + { Louter.msgRole = Louter.RoleAssistant + , Louter.msgContent = [Louter.TextPart $ "Tool call: " <> name' <> " with args: " <> args'] + } + Content user (ToolReturn id' name' ret') _ _ -> + Louter.Message + { Louter.msgRole = Louter.RoleTool + , Louter.msgContent = [Louter.TextPart ret'] + } + in LouterRequest $ orgRequest { Louter.reqMessages = messages } + + fromResponse sessionName (LouterResponse response) = + let choice = head (Louter.respChoices response) + message = Louter.choiceMessage choice + toolCalls = Louter.choiceToolCalls choice + finishReason = case Louter.choiceFinishReason choice of + Just Louter.FinishStop -> Stop + Just Louter.FinishLength -> Length + Just Louter.FinishToolCalls -> ToolCalls + Just Louter.FinishContentFilter -> ContentFilter + Nothing -> Null + -- If there are tool calls, convert them to Content + contents = if null toolCalls + then [Content Assistant (Message message) sessionName defaultUTCTime] + else map (\tc -> Content Assistant + (ToolCall (Louter.rtcId tc) + (Louter.functionName $ Louter.rtcFunction tc) + (Louter.functionArguments $ Louter.rtcFunction tc)) + sessionName + defaultUTCTime) toolCalls + 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 = toRequest + +-- withLLMRequest req' $ \(p :: LLMProxy api) req -> (toRequest' @api p) (toRequest req cs) + +addTools :: [ToolProxy] -> LLMRequest -> LLMRequest +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 + +runRequest :: forall a. (ChatCompletion a) => Text -> LLMRequest -> a -> IO ((a, FinishReason), LLMResponse) +runRequest sessionName (LouterRequest defaultReq) request = do + config <- readConfig + + -- Determine backend type (default to OpenAI if not specified) + let backendType = case Config.backend config of + Just bt -> bt + Nothing -> Config.OpenAI + + let louterBackend = case backendType of + Config.OpenAI -> Louter.BackendOpenAI + { Louter.backendApiKey = Config.apiKey config + , Louter.backendBaseUrl = Just (Config.endpoint config) + , Louter.backendRequiresAuth = not (T.null (Config.apiKey config)) + } + Config.Anthropic -> Louter.BackendAnthropic + { Louter.backendApiKey = Config.apiKey config + , Louter.backendBaseUrl = Just (Config.endpoint config) + , Louter.backendRequiresAuth = not (T.null (Config.apiKey config)) + } + Config.Gemini -> Louter.BackendGemini + { Louter.backendApiKey = Config.apiKey config + , Louter.backendBaseUrl = Just (Config.endpoint config) + , Louter.backendRequiresAuth = not (T.null (Config.apiKey config)) + } + + client <- Louter.newClient louterBackend + let (LouterRequest req) = (toRequest (LouterRequest defaultReq) request) + + lookupEnv "OPENAI_DEBUG" >>= \case + Just "1" -> do + liftIO $ do + BS.putStr $ BS.toStrict $ encodePretty req + T.putStrLn "" + _ -> return () + + 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)