diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,12 @@ # Revision history for intelli-monad +## 0.1.0.2 -- 2024-03-30 + +* Add 'generate' function with typed input and output. +* Add system hook functionality to customize system flow +* Support for key value store + + ## 0.1.0.1 -- 2024-03-21 * Add CLI options diff --git a/app/auto-talk.hs b/app/auto-talk.hs --- a/app/auto-talk.hs +++ b/app/auto-talk.hs @@ -17,20 +17,20 @@ data Haruhi = Haruhi instance CustomInstruction Haruhi where - customHeader = [(Content System (Message "あなたは涼宮ハルヒとして会話してください。話す時は'haruhi: 'をつけて話してください。") "" defaultUTCTime)] - customFooter = [] + customHeader _ = [(Content System (Message "あなたは涼宮ハルヒとして会話してください。話す時は'haruhi: 'をつけて話してください。") "" defaultUTCTime)] + customFooter _ = [] data Kyon = Kyon instance CustomInstruction Kyon where - customHeader = [(Content System (Message "あなたは涼宮ハルヒの同級生のキョンとして会話してください。話す時は'kyon: 'をつけて話してください。") "" defaultUTCTime)] - customFooter = [] + customHeader _ = [(Content System (Message "あなたは涼宮ハルヒの同級生のキョンとして会話してください。話す時は'kyon: 'をつけて話してください。") "" defaultUTCTime)] + customFooter _ = [] data Env = Env instance CustomInstruction Env where - customHeader = [(Content System (Message "あなたは涼宮ハルヒの世界の環境として状況を設定してください。話す時は'env: 'をつけて話してください。") "" defaultUTCTime)] - customFooter = [] + customHeader _ = [(Content System (Message "あなたは涼宮ハルヒの世界の環境として状況を設定してください。話す時は'env: 'をつけて話してください。") "" defaultUTCTime)] + customFooter _ = [] toUser :: Content -> Content toUser c = @@ -40,9 +40,9 @@ main :: IO () main = do - e <- initializePrompt @StatelessConf [] [CustomInstructionProxy (Proxy @Env)] "env" (fromModel "gpt-4") - h <- initializePrompt @StatelessConf [] [CustomInstructionProxy (Proxy @Haruhi)] "haruhi" (fromModel "gpt-4") - k <- initializePrompt @StatelessConf [] [CustomInstructionProxy (Proxy @Kyon)] "kyon" (fromModel "gpt-4") + 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") 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 @@ -5,10 +5,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DuplicateRecordFields #-} module Main where import Data.Aeson +import Data.Text (Text) import Data.Proxy import GHC.Generics import IntelliMonad.Persist @@ -34,14 +36,42 @@ } deriving (Eq, Show, Generic, FromJSON, ToJSON) toolExec _ = return $ ValidateNumberOutput 0 "" "" + toolHeader = [(Content System (Message "Calcurate user input, then output just the number. Then call 'output_number' function.") "" defaultUTCTime)] -data Math = Math -instance CustomInstruction Math where - customHeader = [(Content System (Message "Calcurate user input, then output just the number. Then call 'output_number' function.") "" defaultUTCTime)] - customFooter = [] +data Number = Number + { number :: Double + } + deriving (Eq, Show, Generic, JSONSchema, FromJSON, ToJSON) +instance HasFunctionObject Number where + getFunctionName = "number" + getFunctionDescription = "validate input" + getFieldDescription "number" = "A number" + +instance Tool Number where + data Output Number = NumberOutput + { code :: Int, + stdout :: String, + stderr :: String + } + deriving (Eq, Show, Generic, FromJSON, ToJSON) + toolExec _ = return $ NumberOutput 0 "" "" + +data Input = Input + { formula :: Text + } + deriving (Eq, Show, Generic, JSONSchema, FromJSON, ToJSON) + +instance HasFunctionObject Input where + getFunctionName = "formula" + getFunctionDescription = "Describe a formula" + getFieldDescription "formula" = "A formula" + main :: IO () main = do - v <- runPromptWithValidation @ValidateNumber @StatelessConf [] [CustomInstructionProxy (Proxy @Math)] "default" (fromModel "gpt-4") "2+3+3+sin(3)" + v <- runPromptWithValidation @ValidateNumber @StatelessConf [] [] "default" (fromModel "gpt-4") "2+3+3+sin(3)" print (v :: Maybe ValidateNumber) + + v <- generate [user "Calcurate a formula"] (Input "1+3") + print (v :: Maybe Number) diff --git a/app/repl.hs b/app/repl.hs --- a/app/repl.hs +++ b/app/repl.hs @@ -1,6 +1,6 @@ module Main where + import qualified IntelliMonad.Cmd main :: IO () main = IntelliMonad.Cmd.main - 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.0.1 +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. homepage: https://github.com/junjihashimoto/intelli-monad @@ -43,6 +43,7 @@ , IntelliMonad.Tools.TextToSpeech , IntelliMonad.Tools.DallE3 , IntelliMonad.Tools.Utils + , IntelliMonad.Tools.KeyValue , IntelliMonad.Persist , IntelliMonad.Repl , IntelliMonad.Cmd @@ -81,6 +82,7 @@ , optparse-applicative >= 0.18 && < 0.19 , temporary >= 1.3 && < 1.4 , xml-conduit >= 1.9 && < 2.0 + , yaml >= 0.11 && < 0.12 -- Directories containing source files. hs-source-dirs: src diff --git a/src/IntelliMonad/Cmd.hs b/src/IntelliMonad/Cmd.hs --- a/src/IntelliMonad/Cmd.hs +++ b/src/IntelliMonad/Cmd.hs @@ -20,73 +20,76 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class (MonadTrans, lift) import Control.Monad.Trans.State (get, put) -import Data.Aeson.Encode.Pretty (encodePretty) import qualified Data.Aeson as A +import Data.Aeson.Encode.Pretty (encodePretty) import qualified Data.ByteString as BS import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Void +import Database.Persist.Sqlite (SqliteConf) +import GHC.IO.Exception import IntelliMonad.Persist import IntelliMonad.Prompt -import IntelliMonad.Types 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) +import System.IO (hClose) +import System.IO.Temp +import System.Process import Text.Megaparsec import Text.Megaparsec.Char import Text.Megaparsec.Char.Lexer as L -import GHC.IO.Exception -import System.Process -import System.Environment (lookupEnv) -import System.IO.Temp -import System.IO (hClose) -import Options.Applicative -import Database.Persist.Sqlite (SqliteConf) - opts :: Options.Applicative.Parser ReplCommand -opts = +opts = subparser ( command "repl" (info (Repl <$> argument str (metavar "SESSION_NAME")) (progDesc "Start the repl")) - <> command "clear" (info (pure Clear) (progDesc "Clear the contents")) - <> command "show-contents" (info (pure ShowContents) (progDesc "Show the contents")) - <> command "show-usage" (info (pure ShowUsage) (progDesc "Show the usage")) - <> command "show-request" (info (pure ShowRequest) (progDesc "Show the request")) - <> command "show-context" (info (pure ShowContext) (progDesc "Show the context")) - <> command "show-session" (info (pure ShowSession) (progDesc "Show the session")) - <> command "edit" (info (pure Edit) (progDesc "Edit the contents")) - <> command "edit-request" (info (pure EditRequest) (progDesc "Edit the config of the current session")) - <> command "edit-contents" (info (pure EditContents) (progDesc "Edit the contents of the current session")) - <> command "edit-header" (info (pure EditHeader) (progDesc "Edit the header of the current session")) - <> command "edit-footer" (info (pure EditFooter) (progDesc "Edit the footer of the current session")) - <> command "list-sessions" (info (pure ListSessions) (progDesc "List all sessions")) - <> command "copy-session" (info (CopySession <$> argument str (metavar "FROM") <*> argument str (metavar "TO")) (progDesc "Copy the session")) - <> command "delete-session" (info (DeleteSession <$> argument str (metavar "SESSION_NAME")) (progDesc "Delete the session")) - <> command "switch-session" (info (SwitchSession <$> argument str (metavar "SESSION_NAME")) (progDesc "Switch the session")) - <> command "read-image" (info (ReadImage <$> argument str (metavar "IMAGE_PATH")) (progDesc "Read the image and call a prompt")) - <> command "read-input" (info (UserInput <$> argument str (metavar "USER_INPUT")) (progDesc "User input as a text and call a prompt")) - <> command "help" (info (pure Help) (progDesc "Show the help")) + <> command "clear" (info (pure Clear) (progDesc "Clear the contents")) + <> command "show-contents" (info (pure ShowContents) (progDesc "Show the contents")) + <> command "show-usage" (info (pure ShowUsage) (progDesc "Show the usage")) + <> command "show-request" (info (pure ShowRequest) (progDesc "Show the request")) + <> command "show-context" (info (pure ShowContext) (progDesc "Show the context")) + <> command "show-session" (info (pure ShowSession) (progDesc "Show the session")) + <> command "edit" (info (pure Edit) (progDesc "Edit the contents")) + <> command "edit-request" (info (pure EditRequest) (progDesc "Edit the config of the current session")) + <> command "edit-contents" (info (pure EditContents) (progDesc "Edit the contents of the current session")) + <> command "edit-header" (info (pure EditHeader) (progDesc "Edit the header of the current session")) + <> command "edit-footer" (info (pure EditFooter) (progDesc "Edit the footer of the current session")) + <> command "list-sessions" (info (pure ListSessions) (progDesc "List all sessions")) + <> command "copy-session" (info (CopySession <$> argument str (metavar "FROM") <*> argument str (metavar "TO")) (progDesc "Copy the session")) + <> command "delete-session" (info (DeleteSession <$> argument str (metavar "SESSION_NAME")) (progDesc "Delete the session")) + <> command "switch-session" (info (SwitchSession <$> argument str (metavar "SESSION_NAME")) (progDesc "Switch the session")) + <> command "read-image" (info (ReadImage <$> argument str (metavar "IMAGE_PATH")) (progDesc "Read the image and call a prompt")) + <> command "read-input" (info (UserInput <$> argument str (metavar "USER_INPUT")) (progDesc "User input as a text and call a prompt")) + <> command "list-keys" (info (pure ListKeys) (progDesc "List all keys")) + <> command "get-key" (info (GetKey <$> optional (argument str (metavar "NAMESPACE")) <*> argument str (metavar "KEY_NAME")) (progDesc "Get the key")) + <> command "set-key" (info (SetKey <$> optional (argument str (metavar "NAMESPACE")) <*> argument str (metavar "KEY_NAME") <*> argument str (metavar "KEY_VALUE")) (progDesc "Set the key")) + <> command "delete-key" (info (DeleteKey <$> optional (argument str (metavar "NAMESPACE")) <*> argument str (metavar "KEY_NAME")) (progDesc "Delete the key")) + <> command "help" (info (pure Help) (progDesc "Show the help")) ) runCmd :: forall p. (PersistentBackend p) => ReplCommand -> IO () runCmd cmd = do - let tools = defaultTools - customs = [] - sessionName = "default" - defaultReq = defaultRequest - { API.createChatCompletionRequestModel = API.CreateChatCompletionRequestModel "gpt-4" - } - runInputT - ( Settings - { complete = completeFilename, - historyFile = Just "intelli-monad.history", - autoAddHistory = True - } - ) - (runPrompt @p tools customs sessionName defaultReq (runCmd' @p (Right cmd) Nothing)) - + let tools = defaultTools + customs = [] + sessionName = "default" + defaultReq = + defaultRequest + { API.createChatCompletionRequestModel = API.CreateChatCompletionRequestModel "gpt-4" + } + runInputT + ( Settings + { complete = completeFilename, + historyFile = Just "intelli-monad.history", + autoAddHistory = True + } + ) + (runPrompt @p tools customs sessionName defaultReq (runCmd' @p (Right cmd) Nothing)) main :: IO () main = do @@ -97,5 +100,3 @@ Nothing -> return "gpt-4" cmd <- customExecParser (prefs showHelpOnEmpty) (info (helper <*> opts) (fullDesc <> progDesc "intelli-monad")) runCmd @SqliteConf cmd - - diff --git a/src/IntelliMonad/CustomInstructions.hs b/src/IntelliMonad/CustomInstructions.hs --- a/src/IntelliMonad/CustomInstructions.hs +++ b/src/IntelliMonad/CustomInstructions.hs @@ -52,17 +52,29 @@ data Math = Math instance CustomInstruction Math where - customHeader = [(Content System (Message "Calcurate user input, then output just the number. Then call 'output_number' function.") "" defaultUTCTime)] - customFooter = [] + customHeader _ = [(Content System (Message "Calcurate user input, then output just the number. Then call 'output_number' function.") "" defaultUTCTime)] + customFooter _ = [] headers :: [CustomInstructionProxy] -> Contents headers [] = [] headers (tool : tools') = case tool of - (CustomInstructionProxy (_ :: Proxy a)) -> customHeader @a <> headers tools' + (CustomInstructionProxy a) -> customHeader a <> headers tools' footers :: [CustomInstructionProxy] -> Contents footers [] = [] footers (tool : tools') = case tool of - (CustomInstructionProxy (_ :: Proxy a)) -> customFooter @a <> footers tools' + (CustomInstructionProxy a) -> customFooter a <> footers tools' + +toolHeaders :: [ToolProxy] -> Contents +toolHeaders [] = [] +toolHeaders (tool : tools') = + case tool of + (ToolProxy (_ :: Proxy a)) -> toolHeader @a <> toolHeaders tools' + +toolFooters :: [ToolProxy] -> Contents +toolFooters [] = [] +toolFooters (tool : tools') = + case tool of + (ToolProxy (_ :: Proxy a)) -> toolFooter @a <> toolFooters tools' diff --git a/src/IntelliMonad/Persist.hs b/src/IntelliMonad/Persist.hs --- a/src/IntelliMonad/Persist.hs +++ b/src/IntelliMonad/Persist.hs @@ -29,24 +29,13 @@ import Data.List (maximumBy) import qualified Data.Set as S import Data.Text (Text) -import Database.Persist -import Database.Persist.Sqlite +import Database.Persist hiding (get) +import Database.Persist.Sqlite hiding (get) import IntelliMonad.Types +import Control.Monad.Trans.State (get) data StatelessConf = StatelessConf -class PersistentBackend p where - type Conn p - config :: p - setup :: (MonadIO m, MonadFail m) => p -> m (Maybe (Conn p)) - initialize :: (MonadIO m, MonadFail m) => Conn p -> Context -> m () - load :: (MonadIO m, MonadFail m) => Conn p -> SessionName -> m (Maybe Context) - loadByKey :: (MonadIO m, MonadFail m) => Conn p -> (Key Context) -> m (Maybe Context) - save :: (MonadIO m, MonadFail m) => Conn p -> Context -> m (Maybe (Key Context)) - saveContents :: (MonadIO m, MonadFail m) => Conn p -> [Content] -> m () - listSessions :: (MonadIO m, MonadFail m) => Conn p -> m [Text] - deleteSession :: (MonadIO m, MonadFail m) => Conn p -> SessionName -> m () - instance PersistentBackend SqliteConf where type Conn SqliteConf = ConnectionPool config = @@ -86,6 +75,20 @@ deleteSession conn sessionName = do liftIO $ runPool (config @SqliteConf) (deleteWhere [ContextSessionName ==. sessionName]) conn + listKeys conn = do + (a :: [Entity KeyValue]) <- liftIO $ runPool (config @SqliteConf) (selectList [] []) conn + return $ concat $ map (\(Entity _ v) -> persistUniqueKeys v) a + getKey conn key = do + (a :: Maybe (Entity KeyValue)) <- liftIO $ runPool (config @SqliteConf) (getBy key) conn + case a of + Nothing -> return Nothing + Just (Entity _ v) -> return $ Just $ keyValueValue v + setKey conn (KeyName n' k') value = do + let d = KeyValue n' k' value + liftIO $ runPool (config @SqliteConf) (putMany [d]) conn + deleteKey conn key = do + liftIO $ runPool (config @SqliteConf) (deleteBy key) conn + instance PersistentBackend StatelessConf where type Conn StatelessConf = () config = StatelessConf @@ -97,9 +100,20 @@ saveContents _ _ = return () listSessions _ = return [] deleteSession _ _ = return () + listKeys _ = return [] + getKey _ _ = return Nothing + setKey _ _ _ = return () + deleteKey _ _ = return () withDB :: forall p m a. (MonadIO m, MonadFail m, PersistentBackend p) => (Conn p -> m a) -> m a withDB func = setup (config @p) >>= \case Nothing -> fail "Can not open a database." Just (conn :: Conn p) -> func conn + +withBackend :: forall a m. (MonadIO m, MonadFail m) => (forall p. PersistentBackend p => p -> Prompt m a) -> Prompt m a +withBackend func = do + (env :: PromptEnv) <- get + case (env) of + (PromptEnv _ _ _ (PersistProxy v) _) -> func v + diff --git a/src/IntelliMonad/Prompt.hs b/src/IntelliMonad/Prompt.hs --- a/src/IntelliMonad/Prompt.hs +++ b/src/IntelliMonad/Prompt.hs @@ -53,6 +53,9 @@ _ <- withDB @p $ \conn -> save @p (conn :: Conn p) context return () +getSessionName :: (MonadIO m, MonadFail m) => Prompt m Text +getSessionName = contextSessionName <$> getContext + switchContext :: (MonadIO m, MonadFail m) => Context -> Prompt m () switchContext context = do env <- get @@ -100,10 +103,24 @@ withDB @p $ \conn -> saveContents @p conn contents return () +callPreHook :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => Prompt m () +callPreHook = do + env <- get + forM_ env.hooks $ \(HookProxy (h :: h)) -> do + preHook @h @p h + + +callPostHook :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => Prompt m () +callPostHook = do + env <- get + forM_ env.hooks $ \(HookProxy (h :: h)) -> do + postHook @h @p h + call :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => Prompt m Contents call = loop [] where loop ret = do + 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 @@ -114,6 +131,7 @@ } setContext @p next push @p contents + callPostHook @p let ret' = ret <> contents @@ -127,7 +145,7 @@ callTool next contents ret = do showContents contents env <- get - retTool <- tryToolExec env.tools next.contextSessionName contents + retTool <- tryToolExec @p env.tools next.contextSessionName contents showContents retTool pushToolReturn @p retTool v <- call @p @@ -156,7 +174,9 @@ A.FromJSON (Output validation), A.ToJSON validation, A.ToJSON (Output validation) - ) => Contents -> Prompt m (Maybe validation) + ) => + Contents -> + Prompt m (Maybe validation) callWithValidation contents = do let valid = ToolProxy (Proxy :: Proxy validation) case findToolCall valid contents of @@ -190,6 +210,48 @@ let valid = ToolProxy (Proxy :: Proxy validation) runPrompt @p (valid : tools) customs sessionName req (callWithText @p input >>= callWithValidation @validation @p) +user :: Text -> Content +user input = Content User (Message input) "default" defaultUTCTime + +system :: Text -> Content +system input = Content System (Message input) "default" defaultUTCTime + +assistant :: Text -> Content +assistant input = Content Assistant (Message input) "default" defaultUTCTime + +generate :: + forall input output m p. + ( MonadIO m, + MonadFail m, + p ~ StatelessConf, + A.ToJSON input, + A.FromJSON input, + JSONSchema input, + Tool output, + A.FromJSON output, + A.FromJSON (Output output), + A.ToJSON output, + A.ToJSON (Output output) + ) => Contents -> input -> m (Maybe output) +generate userContext input = do + let valid = ToolProxy (Proxy :: Proxy output) + req = (fromModel "gpt-4") + runPrompt @p [valid] [] "default" req $ do + time <- liftIO getCurrentTime + context <- getContext + let schemaText :: Text + schemaText = T.decodeUtf8Lenient $ BS.toStrict $ A.encode $ toAeson (schema @input) + inputText :: Text + inputText = T.decodeUtf8Lenient $ BS.toStrict $ A.encode input + contents = userContext ++ + [ user ("#User-input format is as follows:\n" <> schemaText) + , user ("#User-input is as follows:\n" <> inputText) + , user ("#Save the processing results using " <> toolFunctionName @output <> " function") + ] + + 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 tools customs sessionName req = do let settings = addTools tools (req {API.createChatCompletionRequestTools = Nothing}) @@ -200,7 +262,9 @@ PromptEnv { context = v, tools = tools, - customInstructions = customs + customInstructions = customs, + backend = (PersistProxy (config @p)), + hooks = [] } Nothing -> do time <- liftIO getCurrentTime @@ -210,15 +274,17 @@ Context { contextRequest = settings, contextResponse = Nothing, - contextHeader = headers customs, + contextHeader = headers customs ++ toolHeaders tools, contextBody = [], - contextFooter = footers customs, + contextFooter = toolFooters tools ++ footers customs, contextTotalTokens = 0, contextSessionName = sessionName, contextCreated = time }, tools = tools, - customInstructions = customs + customInstructions = customs, + backend = (PersistProxy (config @p)), + hooks = [] } initialize @p conn (init'.context) return init' diff --git a/src/IntelliMonad/Repl.hs b/src/IntelliMonad/Repl.hs --- a/src/IntelliMonad/Repl.hs +++ b/src/IntelliMonad/Repl.hs @@ -20,26 +20,28 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class (MonadTrans, lift) import Control.Monad.Trans.State (get, put) -import Data.Aeson.Encode.Pretty (encodePretty) import qualified Data.Aeson as A +import Data.Aeson.Encode.Pretty (encodePretty) +import qualified Data.Yaml as Y +import qualified Data.Yaml.Pretty as Y import qualified Data.ByteString as BS import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Void +import GHC.IO.Exception import IntelliMonad.Persist -import IntelliMonad.Prompt +import IntelliMonad.Prompt hiding (user, system, assistant) import IntelliMonad.Types import qualified OpenAI.Types as API import System.Console.Haskeline +import System.Environment (lookupEnv) +import System.IO (hClose) +import System.IO.Temp +import System.Process import Text.Megaparsec import Text.Megaparsec.Char import Text.Megaparsec.Char.Lexer as L -import GHC.IO.Exception -import System.Process -import System.Environment (lookupEnv) -import System.IO.Temp -import System.IO (hClose) type Parser = Parsec Void Text @@ -91,7 +93,7 @@ Left err -> return $ Left err else return $ Right (UserInput input) -editWithEditor :: forall m. ( MonadIO m, MonadFail m) => m (Maybe T.Text) +editWithEditor :: forall m. (MonadIO m, MonadFail m) => m (Maybe T.Text) editWithEditor = do liftIO $ withSystemTempFile "tempfile.txt" $ \filePath fileHandle -> do hClose fileHandle @@ -104,11 +106,11 @@ 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) => API.CreateChatCompletionRequest -> m (Maybe API.CreateChatCompletionRequest) editRequestWithEditor req = do - liftIO $ withSystemTempFile "tempfile.json" $ \filePath fileHandle -> do + liftIO $ withSystemTempFile "tempfile.yaml" $ \filePath fileHandle -> do hClose fileHandle - BS.writeFile filePath $ BS.toStrict $ encodePretty req + BS.writeFile filePath $ Y.encodePretty Y.defConfig req editor <- do lookupEnv "EDITOR" >>= \case Just editor' -> return editor' @@ -116,17 +118,19 @@ code <- system (editor <> " " <> filePath) case code of ExitSuccess -> do - newReq <- A.decodeFileStrict @API.CreateChatCompletionRequest filePath + newReq <- Y.decodeFileEither @API.CreateChatCompletionRequest filePath case newReq of - Just newReq' -> return $ Just newReq' - Nothing -> return Nothing + Right newReq' -> return $ Just newReq' + Left err -> do + print err + return Nothing ExitFailure _ -> return Nothing -editContentsWithEditor :: forall m. ( MonadIO m, MonadFail m) => Contents -> m (Maybe Contents) +editContentsWithEditor :: forall m. (MonadIO m, MonadFail m) => Contents -> m (Maybe Contents) editContentsWithEditor contents = do - liftIO $ withSystemTempFile "tempfile.json" $ \filePath fileHandle -> do + liftIO $ withSystemTempFile "tempfile.yaml" $ \filePath fileHandle -> do hClose fileHandle - BS.writeFile filePath $ BS.toStrict $ encodePretty contents + BS.writeFile filePath $ Y.encodePretty Y.defConfig contents editor <- do lookupEnv "EDITOR" >>= \case Just editor' -> return editor' @@ -134,10 +138,12 @@ code <- system (editor <> " " <> filePath) case code of ExitSuccess -> do - newContents <- A.decodeFileStrict @Contents filePath + newContents <- Y.decodeFileEither @Contents filePath case newContents of - Just newContents' -> return $ Just newContents' - Nothing -> return Nothing + Right newContents' -> return $ Just newContents' + Left err -> do + print err + return Nothing ExitFailure _ -> return Nothing runCmd' :: forall p. (PersistentBackend p) => Either (ParseErrorBundle Text Void) ReplCommand -> Maybe (Prompt (InputT IO) ()) -> Prompt (InputT IO) () @@ -244,9 +250,8 @@ let req = toRequest prev.contextRequest (prev.contextHeader <> prev.contextBody <> prev.contextFooter) editRequestWithEditor req >>= \case Just req' -> do - (env :: PromptEnv) <- get let newContext = prev {contextRequest = req'} - put $ env {context = newContext} + setContext @p newContext repl Nothing -> do liftIO $ putStrLn "Failed to open the editor." @@ -255,9 +260,8 @@ prev <- getContext editContentsWithEditor prev.contextBody >>= \case Just contents' -> do - (env :: PromptEnv) <- get let newContext = prev {contextBody = contents'} - put $ env {context = newContext} + setContext @p newContext repl Nothing -> do liftIO $ putStrLn "Failed to open the editor." @@ -266,26 +270,51 @@ prev <- getContext editContentsWithEditor prev.contextHeader >>= \case Just contents' -> do - (env :: PromptEnv) <- get let newContext = prev {contextHeader = contents'} - put $ env {context = newContext} - repl + setContext @p newContext Nothing -> do liftIO $ putStrLn "Failed to open the editor." - repl + repl Right EditFooter -> do prev <- getContext editContentsWithEditor prev.contextFooter >>= \case Just contents' -> do - (env :: PromptEnv) <- get let newContext = prev {contextFooter = contents'} - put $ env {context = newContext} + setContext @p newContext repl Nothing -> do liftIO $ putStrLn "Failed to open the editor." repl Right (Repl sessionName) -> do runRepl' @p + Right (ListKeys) -> do + liftIO $ do + list <- withDB @p $ \conn -> listKeys @p conn + forM_ list $ \(KeyName namespace keyName) -> T.putStrLn $ namespace <> ":" <> keyName + repl + Right (GetKey namespace keyName) -> do + namespace' <- case namespace of + Just v -> return v + Nothing -> getSessionName + mv <- withDB @p $ \conn -> getKey @p conn (KeyName namespace' keyName) + case mv of + Just v -> do + liftIO $ T.putStrLn v + Nothing -> do + liftIO $ T.putStrLn $ "Failed to get " <> keyName + repl + Right (SetKey namespace keyName keyValue) -> do + namespace' <- case namespace of + Just v -> return v + Nothing -> getSessionName + withDB @p $ \conn -> setKey @p conn (KeyName namespace' keyName) keyValue + repl + Right (DeleteKey namespace keyName) -> do + namespace' <- case namespace of + Just v -> return v + Nothing -> getSessionName + withDB @p $ \conn -> deleteKey @p conn (KeyName namespace' keyName) + repl runRepl' :: forall p. (PersistentBackend p) => Prompt (InputT IO) () runRepl' = do @@ -302,4 +331,3 @@ } ) (runPrompt @p tools customs sessionName defaultReq (push @p contents >> runRepl' @p)) - diff --git a/src/IntelliMonad/Tools.hs b/src/IntelliMonad/Tools.hs --- a/src/IntelliMonad/Tools.hs +++ b/src/IntelliMonad/Tools.hs @@ -45,6 +45,6 @@ defaultTools :: [ToolProxy] defaultTools = - [ bash - , arxiv + [ bash, + arxiv ] 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 @@ -1,8 +1,8 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} @@ -30,43 +30,46 @@ module IntelliMonad.Tools.Arxiv where import qualified Codec.Picture as P +-- Import HttpClient to make the REST API call + +-- import Network.HTTP.Conduit + +import Control.Exception (SomeException, catch) +import Control.Monad.IO.Class import Control.Monad.Trans.State (StateT) import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode, (.:)) import qualified Data.Aeson as A import qualified Data.Aeson.Key as A import qualified Data.Aeson.KeyMap as A -import qualified Data.ByteString.Char8 as BC import Data.ByteString (ByteString, fromStrict, toStrict) +import qualified Data.ByteString.Char8 as BC import Data.Coerce import Data.Kind (Type) import qualified Data.Map as M +import Data.Maybe (fromMaybe, mapMaybe) import Data.Proxy import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.Lazy as TL import qualified Data.Text.Encoding 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 HttpClient to make the REST API call +import IntelliMonad.Types import Network.HTTP.Client import Network.HTTP.Client.TLS import Network.HTTP.Simple (setRequestQueryString) --- import Network.HTTP.Conduit -import IntelliMonad.Types +import qualified OpenAI.Types as API import Text.XML -import Text.XML.Cursor (Cursor, attributeIs, content, element, fromDocument, ($//), (&/), (&//), Axis, checkName) -import Control.Exception (SomeException, catch) -import Data.Maybe (mapMaybe, fromMaybe) +import Text.XML.Cursor (Axis, Cursor, attributeIs, checkName, content, element, fromDocument, ($//), (&/), (&//)) data Arxiv = Arxiv - { searchQuery :: Text - , maxResults :: Maybe Int - , start :: Maybe Int + { searchQuery :: Text, + maxResults :: Maybe Int, + start :: Maybe Int } deriving (Eq, Show, Generic, JSONSchema, A.FromJSON, A.ToJSON) @@ -78,19 +81,20 @@ getFieldDescription "start" = "The start index of the results. If not specified, the default is 0." arxivSearch :: Arxiv -> IO ByteString -arxivSearch Arxiv{..} = do +arxivSearch Arxiv {..} = do manager <- newManager tlsManagerSettings - let request = setRequestQueryString - [ ("search_query", Just $ T.encodeUtf8 searchQuery) - , ("max_results", Just $ fromMaybe "10" (BC.pack . show <$> maxResults)) - , ("start", Just $ fromMaybe "0" (BC.pack . show <$> start)) - ] - "https://export.arxiv.org/api/query" + let request = + setRequestQueryString + [ ("search_query", Just $ T.encodeUtf8 searchQuery), + ("max_results", Just $ fromMaybe "10" (BC.pack . show <$> maxResults)), + ("start", Just $ fromMaybe "0" (BC.pack . show <$> start)) + ] + "https://export.arxiv.org/api/query" response <- httpLbs request manager return $ toStrict $ responseBody response element' :: Text -> Axis -element' name = checkName (\n -> nameLocalName n == name) +element' name = checkName (\n -> nameLocalName n == name) queryArxiv :: Arxiv -> IO [ArxivEntry] queryArxiv keyword = do @@ -98,24 +102,25 @@ return $ parseArxivXML jsonSource data ArxivEntry = ArxivEntry - { arxivId :: Text - , published :: Text - , title :: Text - , summary :: Text - } deriving (Eq, Show, Generic, A.FromJSON, A.ToJSON) + { arxivId :: Text, + published :: Text, + title :: Text, + summary :: Text + } + deriving (Eq, Show, Generic, A.FromJSON, A.ToJSON) headDef :: a -> [a] -> a headDef d [] = d -headDef _ (x:_) = x +headDef _ (x : _) = x -- | Parser for an Arxiv Entry in XML parseEntry :: Cursor -> Maybe ArxivEntry parseEntry c = - let arxivId = headDef "" $ c $// element' "id" &/ content + let arxivId = headDef "" $ c $// element' "id" &/ content published = headDef "" $ c $// element' "published" &/ content - title = headDef "" $ c $// element' "title" &/ content - summary = headDef "" $ c $// element' "summary" &/ content - in Just $ ArxivEntry arxivId published title summary + title = headDef "" $ c $// element' "title" &/ content + summary = headDef "" $ c $// element' "summary" &/ content + in Just $ ArxivEntry arxivId published title summary -- | Parser for an Arxiv Result in XML parseArxivResult :: Cursor -> [ArxivEntry] @@ -133,6 +138,6 @@ } deriving (Eq, Show, Generic, A.FromJSON, A.ToJSON) - toolExec args = do + toolExec args = liftIO $ do papers <- queryArxiv args return $ ArxivOutput papers 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 @@ -20,6 +20,7 @@ module IntelliMonad.Tools.Bash where +import Control.Monad.IO.Class import qualified Data.Aeson as A import GHC.Generics import GHC.IO.Exception @@ -45,7 +46,7 @@ } deriving (Eq, Show, Generic, A.FromJSON, A.ToJSON) - toolExec args = do + toolExec args = liftIO $ do (code, stdout, stderr) <- readCreateProcessWithExitCode (shell args.script) "" let code' = case code of ExitSuccess -> 0 diff --git a/src/IntelliMonad/Tools/DallE3.hs b/src/IntelliMonad/Tools/DallE3.hs --- a/src/IntelliMonad/Tools/DallE3.hs +++ b/src/IntelliMonad/Tools/DallE3.hs @@ -78,7 +78,7 @@ url :: Text } deriving (Eq, Show, Generic, A.FromJSON, A.ToJSON) - toolExec args = do + toolExec args = liftIO $ do api_key <- (API.clientAuth . T.pack) <$> getEnv "OPENAI_API_KEY" url <- parseBaseUrl "https://api.openai.com/v1/" manager <- newManager tlsManagerSettings diff --git a/src/IntelliMonad/Tools/KeyValue.hs b/src/IntelliMonad/Tools/KeyValue.hs new file mode 100644 --- /dev/null +++ b/src/IntelliMonad/Tools/KeyValue.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module IntelliMonad.Tools.KeyValue where + +import Control.Monad.IO.Class +import qualified Data.Aeson as A +import Data.Text (Text) +import Database.Persist.Sqlite (SqliteConf) +import GHC.Generics +import GHC.IO.Exception +import IntelliMonad.Persist +import IntelliMonad.Prompt +import IntelliMonad.Types +import qualified OpenAI.Types as API +import System.Process +import Data.Proxy + +data GetKey = GetKey + { key :: Text + } + deriving (Eq, Show, Generic, JSONSchema, A.FromJSON, A.ToJSON) + +instance HasFunctionObject GetKey where + getFunctionName = "get_key" + getFunctionDescription = "Get a key from the key-value store" + getFieldDescription "key" = "The key to get" + +data SetKey = SetKey + { key :: Text, + value :: Text + } + deriving (Eq, Show, Generic, JSONSchema, A.FromJSON, A.ToJSON) + +instance HasFunctionObject SetKey where + getFunctionName = "set_key" + getFunctionDescription = "Set a key in the key-value store" + getFieldDescription "key" = "The key to set" + getFieldDescription "value" = "The value to set" + +data DeleteKey = DeleteKey + { key :: Text + } + deriving (Eq, Show, Generic, JSONSchema, A.FromJSON, A.ToJSON) + +instance HasFunctionObject DeleteKey where + getFunctionName = "delete_key" + getFunctionDescription = "Delete a key from the key-value store" + getFieldDescription "key" = "The key to delete" + +data ListKeys = ListKeys () + deriving (Eq, Show, Generic, JSONSchema, A.FromJSON, A.ToJSON) + +instance HasFunctionObject ListKeys where + getFunctionName = "list_keys" + getFunctionDescription = "List all keys in the key-value store" + +instance Tool GetKey where + data Output GetKey = GetKeyOutput + { value :: Text, + code :: Int, + stderr :: Text + } + deriving (Eq, Show, Generic, A.FromJSON, A.ToJSON) + + toolExec args = do + withBackend $ \(_ :: p) -> do + namespace' <- getSessionName + mv <- withDB @p $ \conn -> getKey @p conn (KeyName namespace' args.key) + case mv of + Just v -> return $ GetKeyOutput v 0 "" + Nothing -> return $ GetKeyOutput "" 1 "Key not found" + +instance Tool SetKey where + data Output SetKey = SetKeyOutput + { code :: Int, + stderr :: Text + } + deriving (Eq, Show, Generic, A.FromJSON, A.ToJSON) + + toolExec args = do + withBackend $ \(_ :: p) -> do + namespace' <- getSessionName + withDB @p $ \conn -> setKey @p conn (KeyName namespace' args.key) args.value + return $ SetKeyOutput 0 "" + +instance Tool DeleteKey where + data Output DeleteKey = DeleteKeyOutput + { code :: Int, + stderr :: Text + } + deriving (Eq, Show, Generic, A.FromJSON, A.ToJSON) + + toolExec args = do + withBackend $ \(_ :: p) -> do + namespace' <- getSessionName + withDB @p $ \conn -> deleteKey @p conn (KeyName namespace' args.key) + return $ DeleteKeyOutput 0 "" + +instance Tool ListKeys where + data Output ListKeys = ListKeysOutput + { keys :: [Text], + code :: Int, + stderr :: Text + } + deriving (Eq, Show, Generic, A.FromJSON, A.ToJSON) + + toolExec args = do + withBackend $ \(_ :: p) -> do + namespace' <- getSessionName + keys <- withDB @p $ \conn -> listKeys @p conn + return $ ListKeysOutput (map (\(KeyName _ key) -> key) keys) 0 "" 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 @@ -20,6 +20,7 @@ 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 @@ -51,15 +52,15 @@ stderr :: String } deriving (Eq, Show, Generic, A.FromJSON, A.ToJSON) - toolExec args = do - api_key <- (API.clientAuth . T.pack) <$> getEnv "OPENAI_API_KEY" + 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 = args.script, + API.createSpeechRequestInput = (script args :: T.Text), API.createSpeechRequestVoice = "alloy", API.createSpeechRequestResponseUnderscoreformat = Just "mp3", API.createSpeechRequestSpeed = Nothing 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 @@ -39,8 +39,8 @@ (ToolProxy (_ :: Proxy a)) -> addTools tools' (toolAdd @a v) toolExec' :: - forall t m. - (MonadIO m, MonadFail m, Tool t, A.FromJSON t, A.ToJSON (Output t)) => + forall t p m. + (PersistentBackend p, MonadIO m, MonadFail m, Tool t, A.FromJSON t, A.ToJSON (Output t)) => Text -> Text -> Text -> @@ -51,7 +51,7 @@ then case (A.eitherDecode (BS.fromStrict (T.encodeUtf8 args')) :: Either String t) of Left _ -> return Nothing Right input -> do - output <- liftIO $ toolExec input + output <- toolExec @t @p @m input time <- liftIO getCurrentTime return $ Just $ (Content Tool (ToolReturn id' name' (T.decodeUtf8Lenient (BS.toStrict (encode output)))) sessionName time) else return Nothing @@ -72,11 +72,11 @@ Just v -> return (Just v) Nothing -> tool1 sessionName id' name' args' -mergeToolCall :: (MonadIO m, MonadFail m) => [ToolProxy] -> Text -> Text -> Text -> Text -> Prompt m (Maybe Content) +mergeToolCall :: forall p m. (PersistentBackend p, MonadIO m, MonadFail m) => [ToolProxy] -> Text -> Text -> Text -> Text -> Prompt m (Maybe Content) mergeToolCall [] _ _ _ _ = return Nothing mergeToolCall (tool : tools') sessionName id' name' args' = do case tool of - (ToolProxy (_ :: Proxy a)) -> (toolExec' @a <||> mergeToolCall tools') sessionName id' name' args' + (ToolProxy (_ :: Proxy a)) -> (toolExec' @a @p <||> mergeToolCall @p tools') sessionName id' name' args' hasToolCall :: Contents -> Bool hasToolCall cs = @@ -92,10 +92,10 @@ loop (_ : cs') = loop cs' in loop cs -tryToolExec :: (MonadIO m, MonadFail m) => [ToolProxy] -> Text -> Contents -> Prompt m Contents +tryToolExec :: forall p m. (PersistentBackend p, MonadIO m, MonadFail m) => [ToolProxy] -> Text -> Contents -> Prompt m Contents tryToolExec tools sessionName contents = do cs <- forM (filterToolCall contents) $ \(Content _ (ToolCall id' name' args') _ _) -> do - mergeToolCall tools sessionName id' name' args' + mergeToolCall @p tools sessionName id' name' args' return $ catMaybes cs findToolCall :: ToolProxy -> Contents -> Maybe Content diff --git a/src/IntelliMonad/Types.hs b/src/IntelliMonad/Types.hs --- a/src/IntelliMonad/Types.hs +++ b/src/IntelliMonad/Types.hs @@ -1,8 +1,8 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} @@ -25,11 +25,13 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ExistentialQuantification #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module IntelliMonad.Types where 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 qualified Data.Aeson as A @@ -198,20 +200,43 @@ deriving Show deriving Eq deriving Ord +KeyValue + namespace Text + key Text + value Text + KeyName namespace key + deriving Show + deriving Eq + 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) class CustomInstruction a where - customHeader :: Contents - customFooter :: Contents + customHeader :: a -> Contents + customFooter :: a -> Contents -data CustomInstructionProxy = forall t. (CustomInstruction t) => CustomInstructionProxy (Proxy t) +data CustomInstructionProxy = forall t. (CustomInstruction t) => CustomInstructionProxy t +class Hook a where + preHook :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => a -> Prompt m () + postHook :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => a -> Prompt m () + +data HookProxy = forall t. (Hook t) => HookProxy t + +data PersistProxy = forall t. (PersistentBackend t) => PersistProxy t + data PromptEnv = PromptEnv - { tools :: [ToolProxy], - customInstructions :: [CustomInstructionProxy], - context :: Context + { tools :: [ToolProxy] + -- ^ The list of function calling + , customInstructions :: [CustomInstructionProxy] + -- ^ This system sends a prompt that includes headers, bodies and footers. Then the message that LLM outputs is added to bodies. customInstructions generates headers and footers. + , context :: Context + -- ^ The request settings like model and prompt logs + , backend :: PersistProxy + -- ^ The backend for prompt logging + , hooks :: [HookProxy] + -- ^ The hook functions before or after calling LLM } type Contents = [Content] @@ -258,8 +283,14 @@ default toolSchema :: (HasFunctionObject a, JSONSchema a, Generic a, GSchema a (Rep a)) => API.ChatCompletionTool toolSchema = toChatCompletionTool @a - toolExec :: a -> IO (Output a) + toolExec :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => a -> Prompt m (Output a) + toolHeader :: Contents + toolHeader = [] + toolFooter :: Contents + toolFooter = [] + + toChatCompletionTool :: forall a. (HasFunctionObject a, JSONSchema a) => API.ChatCompletionTool toChatCompletionTool = API.ChatCompletionTool @@ -427,20 +458,49 @@ | EditFooter | ListSessions | CopySession - { sessionNameFrom :: Text - , sessionNameTo :: Text - } + { sessionNameFrom :: Text, + sessionNameTo :: Text + } | DeleteSession - { sessionName :: Text - } + { sessionName :: Text + } | SwitchSession - { sessionName :: Text - } + { sessionName :: Text + } | ReadImage Text | UserInput Text | Help - | Repl - { sessionName :: Text - } + | Repl + { sessionName :: Text + } + | ListKeys + | GetKey + { nameSpace :: Maybe Text, + keyName :: Text + } + | SetKey + { nameSpace :: Maybe Text, + keyName :: Text, + value :: Text + } + | DeleteKey + { nameSpace :: Maybe Text, + keyName :: Text + } deriving (Eq, Show) +class PersistentBackend p where + type Conn p + config :: p + setup :: (MonadIO m, MonadFail m) => p -> m (Maybe (Conn p)) + initialize :: (MonadIO m, MonadFail m) => Conn p -> Context -> m () + load :: (MonadIO m, MonadFail m) => Conn p -> SessionName -> m (Maybe Context) + loadByKey :: (MonadIO m, MonadFail m) => Conn p -> (Key Context) -> m (Maybe Context) + save :: (MonadIO m, MonadFail m) => Conn p -> Context -> m (Maybe (Key Context)) + saveContents :: (MonadIO m, MonadFail m) => Conn p -> [Content] -> m () + listSessions :: (MonadIO m, MonadFail m) => Conn p -> m [Text] + deleteSession :: (MonadIO m, MonadFail m) => Conn p -> SessionName -> m () + listKeys :: (MonadIO m, MonadFail m) => Conn p -> m [Unique KeyValue] + 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 ()