intelli-monad 0.1.0.2 → 0.1.1.0
raw patch · 11 files changed
+402/−236 lines, 11 filesdep +aeson-casingdep +exceptionsdep +http-typesdep ~basedep ~bytestringdep ~openai-servant-gen
Dependencies added: aeson-casing, exceptions, http-types, kan-extensions, louter, mtl, servant-client-core, servant-server, stm, wai, wai-extra, warp
Dependency ranges changed: base, bytestring, openai-servant-gen, servant, text
Files
- README.md +14/−0
- app/auto-talk.hs +6/−3
- app/calc.hs +4/−2
- intelli-monad.cabal +25/−11
- src/IntelliMonad/Cmd.hs +4/−5
- src/IntelliMonad/Config.hs +42/−0
- src/IntelliMonad/Prompt.hs +18/−117
- src/IntelliMonad/Repl.hs +5/−3
- src/IntelliMonad/Tools/TextToSpeech.hs +2/−0
- src/IntelliMonad/Tools/Utils.hs +0/−6
- src/IntelliMonad/Types.hs +282/−89
README.md view
@@ -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.
app/auto-talk.hs view
@@ -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
app/calc.hs view
@@ -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")
intelli-monad.cabal view
@@ -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
src/IntelliMonad/Cmd.hs view
@@ -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
+ src/IntelliMonad/Config.hs view
@@ -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
src/IntelliMonad/Prompt.hs view
@@ -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
src/IntelliMonad/Repl.hs view
@@ -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,
src/IntelliMonad/Tools/TextToSpeech.hs view
@@ -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
src/IntelliMonad/Tools/Utils.hs view
@@ -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)) =>
src/IntelliMonad/Types.hs view
@@ -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)