diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,28 @@ # Revision history for intelli-monad +## 0.1.3.0 -- 2026-04-27 + +### Added +* New REPL command `:model` for switching the active model at runtime. +* Model name can now be set via the config file and overridden by an environment variable. +* `OPENAI_HTTP_DEBUG` environment variable and additional HTTP debugging settings. +* Timeout passthrough to the louter backend. +* Helper functions used by the examples are now exported from `IntelliMonad.Prompt`. + +### Changed +* Default model switched to an open-weight option; the default model name is now empty (must be supplied via config or environment). +* REPL command prefix changed from `/` to `:` (e.g. `:model`, `:help`). +* `cabal.project` no longer requires cabal files in parent directories. + +### Removed +* Removed `cabal.project.freeze` so the package builds on Debian. + +### Internal +* Hid unused functions and tidied up `IntelliMonad.Prompt` / `IntelliMonad.Types`. + +### Acknowledgments +* Many thanks to [@julialongtin](https://github.com/julialongtin) (Julia Longtin) for contributing all of the changes in this release. + ## 0.1.0.2 -- 2024-03-30 * Add 'generate' function with typed input and output. 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.2.0 +version: 0.1.3.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 @@ -73,7 +73,7 @@ , 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 + , louter >= 0.1.1.2 && < 0.1.2 , persistent >= 2.14.6 && < 2.15 , persistent-sqlite >= 2.13.3 && < 2.14 , sixel >= 0.1.2 && < 0.2 diff --git a/src/IntelliMonad/Cmd.hs b/src/IntelliMonad/Cmd.hs --- a/src/IntelliMonad/Cmd.hs +++ b/src/IntelliMonad/Cmd.hs @@ -45,6 +45,9 @@ import Text.Megaparsec.Char import Text.Megaparsec.Char.Lexer as L +-- Our request contains the target server, and model type. +import Louter.Types.Request (ChatRequest) + opts :: Options.Applicative.Parser ReplCommand opts = subparser @@ -73,13 +76,12 @@ <> command "help" (info (pure Help) (progDesc "Show the help")) ) -runCmd :: forall p. (PersistentBackend p) => ReplCommand -> IO () -runCmd cmd = do +runCmd :: forall p. (PersistentBackend p) => ChatRequest -> ReplCommand -> IO () +runCmd request cmd = do config <- readConfig let tools = defaultTools customs = [] sessionName = "default" - defaultReq = defaultRequest runInputT ( Settings { complete = completeFilename, @@ -87,14 +89,19 @@ autoAddHistory = True } ) - (runPrompt @p [] customs sessionName defaultReq (runCmd' @p (Right cmd) Nothing)) + (runPrompt @p [] customs sessionName request (runCmd' @p (Right cmd) Nothing)) main :: IO () main = do + -- Parse our config file. We only use the model, at this point. + config <- readConfig + + -- Determine what model to use by default. Use what's in the config file by default, but override with an environment variable (OPENAI_MODEL). model <- do lookupEnv "OPENAI_MODEL" >>= \case Just model -> return $ T.pack model - -- Nothing -> return "gpt-4-vision-preview" - Nothing -> return "gpt-4" + Nothing -> return config.model + cmd <- customExecParser (prefs showHelpOnEmpty) (info (helper <*> opts) (fullDesc <> progDesc "intelli-monad")) - runCmd @SqliteConf cmd + + runCmd @SqliteConf (fromModel model) cmd diff --git a/src/IntelliMonad/Config.hs b/src/IntelliMonad/Config.hs --- a/src/IntelliMonad/Config.hs +++ b/src/IntelliMonad/Config.hs @@ -30,9 +30,16 @@ , endpoint :: Text , model :: Text , backend :: Maybe BackendType -- Optional, defaults to openai + , useStreaming :: Maybe Bool -- Optional, defaults to True } deriving (Show, Generic) instance FromJSON Config + +-- | Get whether to use streaming (defaults to True if not specified) +getUseStreaming :: Config -> Bool +getUseStreaming cfg = case useStreaming cfg of + Just val -> val + Nothing -> True -- Default to streaming enabled readConfig :: IO Config readConfig = do diff --git a/src/IntelliMonad/Persist.hs b/src/IntelliMonad/Persist.hs --- a/src/IntelliMonad/Persist.hs +++ b/src/IntelliMonad/Persist.hs @@ -115,5 +115,5 @@ withBackend func = do (env :: PromptEnv) <- get case (env) of - (PromptEnv _ _ _ (PersistProxy v) _) -> func v + (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 @@ -15,7 +15,24 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module IntelliMonad.Prompt where +module IntelliMonad.Prompt + ( + callWithContents, + callWithImage, + callWithText, + clear, + generate, + getContext, + getSessionName, + initializePrompt, + push, + setContext, + user, + runPrompt, + runPromptWithValidation, + showContents + ) +where import Control.Monad (forM_) import Control.Monad.IO.Class @@ -32,7 +49,8 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import Data.Time -import IntelliMonad.Config +import IntelliMonad.Config (readConfig) +import qualified IntelliMonad.Config as Config import IntelliMonad.CustomInstructions import IntelliMonad.Persist import IntelliMonad.Tools @@ -42,6 +60,7 @@ import Network.HTTP.Client (managerResponseTimeout, newManager, responseTimeoutMicro) import Network.HTTP.Client.TLS (tlsManagerSettings) import System.Environment (getEnv, lookupEnv) +import qualified System.IO as IO getContext :: (MonadIO m, MonadFail m) => Prompt m Context getContext = context <$> get @@ -56,12 +75,6 @@ getSessionName :: (MonadIO m, MonadFail m) => Prompt m Text getSessionName = contextSessionName <$> getContext -switchContext :: (MonadIO m, MonadFail m) => Context -> Prompt m () -switchContext context = do - env <- get - put $ env {context = context} - return () - push :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => Contents -> Prompt m () push contents = do prev <- getContext @@ -122,7 +135,23 @@ loop ret = do callPreHook @p prev <- getContext - ((contents, finishReason), res) <- liftIO $ runRequest prev.contextSessionName prev.contextRequest (prev.contextHeader <> prev.contextBody <> prev.contextFooter) + config <- liftIO readConfig + env <- get + + -- Check if streaming is enabled + let streaming = Config.getUseStreaming config + + ((contents, finishReason), res) <- if streaming + then do + -- Use streaming with incremental output + liftIO $ runRequestStreaming prev.contextSessionName prev.contextRequest env.timeoutSeconds + (prev.contextHeader <> prev.contextBody <> prev.contextFooter) + (\chunk -> T.putStr chunk >> IO.hFlush IO.stdout) -- Stream to stdout + else do + -- Use non-streaming + liftIO $ runRequest prev.contextSessionName prev.contextRequest env.timeoutSeconds + (prev.contextHeader <> prev.contextBody <> prev.contextFooter) + let current_total_tokens = 0 -- fromMaybe 0 $ API.completionUsageTotalUnderscoretokens <$> API.createChatCompletionResponseUsage res next = prev @@ -164,100 +193,6 @@ push @p input call @p -callWithValidation :: - forall validation p m. - ( MonadIO m, - MonadFail m, - PersistentBackend p, - Tool validation, - A.FromJSON validation, - A.FromJSON (Output validation), - A.ToJSON validation, - A.ToJSON (Output validation), - HasFunctionObject validation, - JSONSchema validation - ) => - Contents -> - Prompt m (Maybe validation) -callWithValidation contents = do - let valid = ToolProxy (Proxy :: Proxy validation) - case findToolCall valid contents of - Just (Content _ (ToolCall _ _ args') _ _) -> do - let v = (A.eitherDecode (BS.fromStrict (T.encodeUtf8 args')) :: Either String validation) - case v of - Left err -> do - liftIO $ putStrLn err - return Nothing - Right v' -> return $ Just v' - _ -> return Nothing - -runPromptWithValidation :: - forall validation p m. - ( MonadIO m, - MonadFail m, - PersistentBackend p, - Tool validation, - A.FromJSON validation, - A.FromJSON (Output validation), - A.ToJSON validation, - A.ToJSON (Output validation), - HasFunctionObject validation, - JSONSchema validation - ) => - [ToolProxy] -> - [CustomInstructionProxy] -> - Text -> - Louter.ChatRequest -> - Text -> - m (Maybe validation) -runPromptWithValidation tools customs sessionName req input = do - 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), - HasFunctionObject output, - JSONSchema 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 -> Louter.ChatRequest -> m PromptEnv initializePrompt tools customs sessionName req = do -- config <- readConfig @@ -334,3 +269,111 @@ context <- getContext let contents' = [Content User (Image imageType file) context.contextSessionName time] callWithContents @p contents' + +-- Only called by calc example. + +user :: Text -> Content +user input = Content User (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), + HasFunctionObject output, + JSONSchema 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 + +runPromptWithValidation :: + forall validation p m. + ( MonadIO m, + MonadFail m, + PersistentBackend p, + Tool validation, + A.FromJSON validation, + A.FromJSON (Output validation), + A.ToJSON validation, + A.ToJSON (Output validation), + HasFunctionObject validation, + JSONSchema validation + ) => + [ToolProxy] -> + [CustomInstructionProxy] -> + Text -> + Louter.ChatRequest -> + Text -> + m (Maybe validation) +runPromptWithValidation tools customs sessionName req input = do + let valid = ToolProxy (Proxy :: Proxy validation) + runPrompt @p (valid : tools) customs sessionName req (callWithText @p input >>= callWithValidation @validation @p) + +callWithValidation :: + forall validation p m. + ( MonadIO m, + MonadFail m, + PersistentBackend p, + Tool validation, + A.FromJSON validation, + A.FromJSON (Output validation), + A.ToJSON validation, + A.ToJSON (Output validation), + HasFunctionObject validation, + JSONSchema validation + ) => + Contents -> + Prompt m (Maybe validation) +callWithValidation contents = do + let valid = ToolProxy (Proxy :: Proxy validation) + case findToolCall valid contents of + Just (Content _ (ToolCall _ _ args') _ _) -> do + let v = (A.eitherDecode (BS.fromStrict (T.encodeUtf8 args')) :: Either String validation) + case v of + Left err -> do + liftIO $ putStrLn err + return Nothing + Right v' -> return $ Just v' + _ -> return Nothing + +-- Everything below this line is not called. + +{- + +switchContext :: (MonadIO m, MonadFail m) => Context -> Prompt m () +switchContext context = do + env <- get + put $ env {context = context} + return () + +system :: Text -> Content +system input = Content System (Message input) "default" defaultUTCTime + +assistant :: Text -> Content +assistant input = Content Assistant (Message input) "default" defaultUTCTime +-} + diff --git a/src/IntelliMonad/Repl.hs b/src/IntelliMonad/Repl.hs --- a/src/IntelliMonad/Repl.hs +++ b/src/IntelliMonad/Repl.hs @@ -50,11 +50,13 @@ parseRepl = (try (lexm (string ":quit")) >> pure Quit) <|> (try (lexm (string ":clear")) >> pure Clear) + <|> (try (lexm (string ":model") >> T.pack <$> lexm modelName) >>= pure . SetModel) <|> (try (lexm (string ":show") >> lexm (string "contents")) >> pure ShowContents) <|> (try (lexm (string ":show") >> lexm (string "usage")) >> pure ShowUsage) <|> (try (lexm (string ":show") >> lexm (string "request")) >> pure ShowRequest) <|> (try (lexm (string ":show") >> lexm (string "context")) >> pure ShowContext) <|> (try (lexm (string ":show") >> lexm (string "session")) >> pure ShowSession) + <|> (try (lexm (string ":set" ) >> lexm (string "timeout") >> L.decimal) >>= pure . SetTimeout) <|> (try (lexm (string ":read") >> lexm (string "image") >> lexm imagePath) >>= pure . ReadImage . T.pack) <|> (try (lexm (string ":list") >> lexm (string "sessions")) >> pure ListSessions) <|> (try (lexm (string ":list")) >> pure ListSessions) @@ -78,6 +80,7 @@ lexm = lexeme sc sessionName = many alphaNumChar imagePath = many (alphaNumChar <|> char '.' <|> char '/' <|> char '-') + modelName = many (alphaNumChar <|> char '-' <|> char '.' <|> char ':' <|> char '/') getTextInputLine :: (MonadTrans t) => t (InputT IO) (Maybe T.Text) getTextInputLine = fmap (fmap T.pack) (lift $ getInputLine "% ") @@ -159,6 +162,18 @@ Right Quit -> return () Right Clear -> do clear @p + repl + Right (SetModel modelName) -> do + prev <- getContext + let req = prev.contextRequest { Louter.reqModel = modelName } + newContext = prev {contextRequest = req} + setContext @p newContext + liftIO $ T.putStrLn $ "Model set to: " <> modelName + repl + Right (SetTimeout timeout) -> do + env <- get + put $ env { timeoutSeconds = Just timeout } + liftIO $ T.putStrLn $ "Timeout set to: " <> T.pack (show timeout) <> " seconds" repl Right ShowContents -> do context <- getContext diff --git a/src/IntelliMonad/Types.hs b/src/IntelliMonad/Types.hs --- a/src/IntelliMonad/Types.hs +++ b/src/IntelliMonad/Types.hs @@ -33,9 +33,11 @@ module IntelliMonad.Types where import qualified Codec.Picture as P +import Control.Monad (when) import Control.Monad.IO.Class import Control.Monad.Trans.State (StateT) import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode, Value) +import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef') import Data.Map (Map) import qualified Data.Aeson as A import qualified Data.Aeson.Key as A @@ -61,6 +63,7 @@ import qualified Louter.Client as Louter import qualified Louter.Types.Request as Louter import qualified Louter.Types.Response as Louter +import qualified Louter.Types.Streaming as Louter import IntelliMonad.Config (readConfig) import qualified IntelliMonad.Config as Config import qualified Data.ByteString as BS @@ -295,6 +298,8 @@ -- ^ The backend for prompt logging , hooks :: [HookProxy] -- ^ The hook functions before or after calling LLM + , timeoutSeconds :: Maybe Int + -- ^ The timeout in seconds to wait for results. Given to Louter. } type Contents = [Content] @@ -599,6 +604,8 @@ | EditHeader | EditFooter | ListSessions + | SetModel Text + | SetTimeout Int | CopySession { sessionNameFrom :: Text, sessionNameTo :: Text @@ -648,10 +655,11 @@ deleteKey :: (MonadIO m, MonadFail m) => Conn p -> Unique KeyValue -> m () +-- FIXME: use mempty here, instead of providing a model name. defaultRequest :: Louter.ChatRequest defaultRequest = Louter.ChatRequest - { Louter.reqModel = "gpt-4" + { Louter.reqModel = "" , Louter.reqMessages = [] , Louter.reqTools = [] , Louter.reqToolChoice = Louter.ToolChoiceAuto @@ -760,8 +768,8 @@ fromModel :: Text -> Louter.ChatRequest fromModel = fromModel_ -runRequest :: forall a. (ChatCompletion a) => Text -> Louter.ChatRequest -> a -> IO ((a, FinishReason), Louter.ChatResponse) -runRequest sessionName defaultReq request = do +runRequest :: forall a. (ChatCompletion a) => Text -> Louter.ChatRequest -> Maybe Int -> a -> IO ((a, FinishReason), Louter.ChatResponse) +runRequest sessionName defaultReq timeout request = do config <- readConfig -- Determine backend type (default to OpenAI if not specified) @@ -786,17 +794,125 @@ , Louter.backendRequiresAuth = not (T.null (Config.apiKey config)) } - client <- Louter.newClient louterBackend + client <- Louter.newClientWithTimeout timeout louterBackend let req = toRequest defaultReq request - lookupEnv "OPENAI_DEBUG" >>= \case - Just "1" -> do + openai_debug <- maybe False (== "1") <$> lookupEnv "OPENAI_DEBUG" + when openai_debug $ do liftIO $ do + T.putStrLn "========== Request ===========" BS.putStr $ BS.toStrict $ encodePretty req T.putStrLn "" - _ -> return () + openai_http_debug <- maybe False (== "1") <$> lookupEnv "OPENAI_HTTP_DEBUG" + when openai_http_debug $ do + liftIO $ do + T.putStrLn "========== Backend ===========" + print louterBackend + T.putStrLn "========== Request ===========" + BS.putStr $ BS.toStrict $ encodePretty req + T.putStrLn "" + result <- Louter.chatCompletion client req case result of Left err -> error $ T.unpack $ "Louter error: " <> err - Right res -> return $ (fromResponse sessionName res, res) + Right res -> do + when openai_http_debug $ do + T.putStrLn "========== Response ==========" + BS.putStr $ BS.toStrict $ encodePretty res + T.putStrLn "" + return $ (fromResponse sessionName res, res) + +runRequestStreaming :: forall a. (ChatCompletion a) => Text -> Louter.ChatRequest -> Maybe Int -> a -> (Text -> IO ()) -> IO ((a, FinishReason), Louter.ChatResponse) +runRequestStreaming sessionName defaultReq timeout request contentCallback = 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.newClientWithTimeout timeout louterBackend + let req = toRequest defaultReq request + + openai_debug <- maybe False (== "1") <$> lookupEnv "OPENAI_DEBUG" + when openai_debug $ do + liftIO $ do + T.putStrLn "========== Request ===========" + BS.putStr $ BS.toStrict $ encodePretty req + T.putStrLn "" + + openai_http_debug <- maybe False (== "1") <$> lookupEnv "OPENAI_HTTP_DEBUG" + when openai_http_debug $ do + liftIO $ do + T.putStrLn "========== Backend ===========" + print louterBackend + T.putStrLn "========== Request ===========" + BS.putStr $ BS.toStrict $ encodePretty req + T.putStrLn "" + + -- Accumulate response while streaming + contentRef <- newIORef [] + finishReasonRef <- newIORef "stop" + + -- Stream with callback + Louter.streamChatWithCallback client req $ \event -> case event of + Louter.StreamContent txt -> do + contentCallback txt -- Call user callback for incremental output + modifyIORef' contentRef (++ [txt]) + Louter.StreamFinish reason -> do + writeIORef finishReasonRef reason + Louter.StreamError err -> do + error $ T.unpack $ "Louter streaming error: " <> err + _ -> pure () -- Ignore reasoning and tool calls for now + + -- Build response from accumulated content + fullContent <- T.concat <$> readIORef contentRef + finishReasonText <- readIORef finishReasonRef + + -- Convert text finish reason to FinishReason type + let finishReason = case finishReasonText of + "stop" -> Louter.FinishStop + "length" -> Louter.FinishLength + "tool_calls" -> Louter.FinishToolCalls + "content_filter" -> Louter.FinishContentFilter + _ -> Louter.FinishStop + + -- Create a minimal ChatResponse for compatibility + let response = Louter.ChatResponse + { Louter.respId = "stream-1" + , Louter.respModel = Louter.reqModel req + , Louter.respChoices = + [ Louter.Choice + { Louter.choiceIndex = 0 + , Louter.choiceMessage = fullContent + , Louter.choiceToolCalls = [] + , Louter.choiceFinishReason = Just finishReason + } + ] + , Louter.respUsage = Nothing + } + + when openai_http_debug $ do + T.putStrLn "==== Response (Accumulated) ====" + BS.putStr $ BS.toStrict $ encodePretty response + T.putStrLn "" + + return $ (fromResponse sessionName response, response)