intelli-monad 0.1.2.0 → 0.1.3.0

raw patch · 8 files changed

+332/−121 lines, 8 filesdep ~louterPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: louter

API changes (from Hackage documentation)

Files

• CHANGELOG.md +23/−0
• intelli-monad.cabal +2/−2
• src/IntelliMonad/Cmd.hs +14/−7
• src/IntelliMonad/Config.hs +7/−0
• src/IntelliMonad/Persist.hs +1/−1
• src/IntelliMonad/Prompt.hs +146/−103
• src/IntelliMonad/Repl.hs +15/−0
• src/IntelliMonad/Types.hs +124/−8

@@ -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.

@@ -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

@@ -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

@@ -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

@@ -115,5 +115,5 @@ withBackend func = do   (env :: PromptEnv) <- get   case (env) of-    (PromptEnv _ _ _ (PersistProxy v) _) -> func v+    (PromptEnv _ _ _ (PersistProxy v) _ _) -> func v 

@@ -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+-}+

@@ -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

@@ -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)