{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module IntelliMonad.Prompt where

import Control.Monad (forM_)
import Control.Monad.IO.Class
import Control.Monad.Trans.State (get, put, runStateT)
import qualified Data.Aeson as A
import Data.Aeson.Encode.Pretty (encodePretty)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as Base64
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Data.Proxy
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import Data.Time
import IntelliMonad.CustomInstructions
import IntelliMonad.Persist
import IntelliMonad.Tools
import IntelliMonad.Types
import Network.HTTP.Client (managerResponseTimeout, newManager, responseTimeoutMicro)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import qualified OpenAI.API as API
import qualified OpenAI.Types as API
import Servant.Client (mkClientEnv, parseBaseUrl)
import System.Environment (getEnv, lookupEnv)

getContext :: (MonadIO m, MonadFail m) => Prompt m Context
getContext :: forall (m :: * -> *). (MonadIO m, MonadFail m) => Prompt m Context
getContext = PromptEnv -> Context
context (PromptEnv -> Context)
-> StateT PromptEnv m PromptEnv -> StateT PromptEnv m Context
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT PromptEnv m PromptEnv
forall (m :: * -> *) s. Monad m => StateT s m s
get

setContext :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => Context -> Prompt m ()
setContext :: forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Context -> Prompt m ()
setContext Context
context = do
  PromptEnv
env <- StateT PromptEnv m PromptEnv
forall (m :: * -> *) s. Monad m => StateT s m s
get
  PromptEnv -> Prompt m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (PromptEnv -> Prompt m ()) -> PromptEnv -> Prompt m ()
forall a b. (a -> b) -> a -> b
$ PromptEnv
env {context = context}
  Maybe (Key Context)
_ <- forall p (m :: * -> *) a.
(MonadIO m, MonadFail m, PersistentBackend p) =>
(Conn p -> m a) -> m a
withDB @p ((Conn p -> StateT PromptEnv m (Maybe (Key Context)))
 -> StateT PromptEnv m (Maybe (Key Context)))
-> (Conn p -> StateT PromptEnv m (Maybe (Key Context)))
-> StateT PromptEnv m (Maybe (Key Context))
forall a b. (a -> b) -> a -> b
$ \Conn p
conn -> forall p (m :: * -> *).
(PersistentBackend p, MonadIO m, MonadFail m) =>
Conn p -> Context -> m (Maybe (Key Context))
save @p (Conn p
conn :: Conn p) Context
context
  () -> Prompt m ()
forall a. a -> StateT PromptEnv m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

getSessionName :: (MonadIO m, MonadFail m) => Prompt m Text
getSessionName :: forall (m :: * -> *). (MonadIO m, MonadFail m) => Prompt m Text
getSessionName = Context -> Text
contextSessionName (Context -> Text)
-> StateT PromptEnv m Context -> StateT PromptEnv m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT PromptEnv m Context
forall (m :: * -> *). (MonadIO m, MonadFail m) => Prompt m Context
getContext

switchContext :: (MonadIO m, MonadFail m) => Context -> Prompt m ()
switchContext :: forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Context -> Prompt m ()
switchContext Context
context = do
  PromptEnv
env <- StateT PromptEnv m PromptEnv
forall (m :: * -> *) s. Monad m => StateT s m s
get
  PromptEnv -> Prompt m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (PromptEnv -> Prompt m ()) -> PromptEnv -> Prompt m ()
forall a b. (a -> b) -> a -> b
$ PromptEnv
env {context = context}
  () -> Prompt m ()
forall a. a -> StateT PromptEnv m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

push :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => Contents -> Prompt m ()
push :: forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Contents -> Prompt m ()
push Contents
contents = do
  Context
prev <- Prompt m Context
forall (m :: * -> *). (MonadIO m, MonadFail m) => Prompt m Context
getContext
  let nextContents :: Contents
nextContents = Context
prev.contextBody Contents -> Contents -> Contents
forall a. Semigroup a => a -> a -> a
<> Contents
contents
      next :: Context
next =
        Context
prev
          { contextBody = nextContents,
            contextRequest = toRequest prev.contextRequest (prev.contextHeader <> nextContents <> prev.contextFooter)
          }
  forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Context -> Prompt m ()
setContext @p Context
next

  forall p (m :: * -> *) a.
(MonadIO m, MonadFail m, PersistentBackend p) =>
(Conn p -> m a) -> m a
withDB @p ((Conn p -> Prompt m ()) -> Prompt m ())
-> (Conn p -> Prompt m ()) -> Prompt m ()
forall a b. (a -> b) -> a -> b
$ \Conn p
conn -> forall p (m :: * -> *).
(PersistentBackend p, MonadIO m, MonadFail m) =>
Conn p -> Contents -> m ()
saveContents @p Conn p
conn Contents
contents
  () -> Prompt m ()
forall a. a -> StateT PromptEnv m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

pushToolReturn :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => Contents -> Prompt m ()
pushToolReturn :: forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Contents -> Prompt m ()
pushToolReturn Contents
contents = do
  Context
prev <- Prompt m Context
forall (m :: * -> *). (MonadIO m, MonadFail m) => Prompt m Context
getContext
  let toolMap :: Map Text Content
toolMap = [(Text, Content)] -> Map Text Content
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ((Content -> (Text, Content)) -> Contents -> [(Text, Content)]
forall a b. (a -> b) -> [a] -> [b]
map (\v :: Content
v@(Content User
_ (ToolReturn Text
id' Text
_ Text
_) Text
_ UTCTime
_) -> (Text
id', Content
v)) Contents
contents)
      nextContents :: Contents
nextContents =
        [Contents] -> Contents
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Contents] -> Contents) -> [Contents] -> Contents
forall a b. (a -> b) -> a -> b
$
          (Content -> Contents) -> Contents -> [Contents]
forall a b. (a -> b) -> [a] -> [b]
map
            ( \Content
v -> case Content
v of
                Content User
_ (Message Text
_) Text
_ UTCTime
_ -> [Item Contents
Content
v]
                Content User
_ (Image Text
_ Text
_) Text
_ UTCTime
_ -> [Item Contents
Content
v]
                Content User
_ (ToolCall Text
id' Text
_ Text
_) Text
_ UTCTime
_ ->
                  case Text -> Map Text Content -> Maybe Content
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
id' Map Text Content
toolMap of
                    Just Content
v' -> [Item Contents
Content
v, Item Contents
Content
v']
                    Maybe Content
Nothing -> [Item Contents
Content
v]
                Content User
_ (ToolReturn Text
_ Text
_ Text
_) Text
_ UTCTime
_ -> [Item Contents
Content
v]
            )
            Context
prev.contextBody
      next :: Context
next =
        Context
prev
          { contextBody = nextContents,
            contextRequest = toRequest prev.contextRequest (prev.contextHeader <> nextContents <> prev.contextFooter)
          }
  forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Context -> Prompt m ()
setContext @p Context
next

  forall p (m :: * -> *) a.
(MonadIO m, MonadFail m, PersistentBackend p) =>
(Conn p -> m a) -> m a
withDB @p ((Conn p -> Prompt m ()) -> Prompt m ())
-> (Conn p -> Prompt m ()) -> Prompt m ()
forall a b. (a -> b) -> a -> b
$ \Conn p
conn -> forall p (m :: * -> *).
(PersistentBackend p, MonadIO m, MonadFail m) =>
Conn p -> Contents -> m ()
saveContents @p Conn p
conn Contents
contents
  () -> Prompt m ()
forall a. a -> StateT PromptEnv m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

callPreHook :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => Prompt m ()
callPreHook :: forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Prompt m ()
callPreHook = do
  PromptEnv
env <- StateT PromptEnv m PromptEnv
forall (m :: * -> *) s. Monad m => StateT s m s
get
  [HookProxy] -> (HookProxy -> Prompt m ()) -> Prompt m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ PromptEnv
env.hooks ((HookProxy -> Prompt m ()) -> Prompt m ())
-> (HookProxy -> Prompt m ()) -> Prompt m ()
forall a b. (a -> b) -> a -> b
$ \(HookProxy (t
h :: h)) -> do
    forall a p (m :: * -> *).
(Hook a, MonadIO m, MonadFail m, PersistentBackend p) =>
a -> Prompt m ()
preHook @h @p t
h
  

callPostHook :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => Prompt m ()
callPostHook :: forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Prompt m ()
callPostHook = do
  PromptEnv
env <- StateT PromptEnv m PromptEnv
forall (m :: * -> *) s. Monad m => StateT s m s
get
  [HookProxy] -> (HookProxy -> Prompt m ()) -> Prompt m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ PromptEnv
env.hooks ((HookProxy -> Prompt m ()) -> Prompt m ())
-> (HookProxy -> Prompt m ()) -> Prompt m ()
forall a b. (a -> b) -> a -> b
$ \(HookProxy (t
h :: h)) -> do
    forall a p (m :: * -> *).
(Hook a, MonadIO m, MonadFail m, PersistentBackend p) =>
a -> Prompt m ()
postHook @h @p t
h

call :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => Prompt m Contents
call :: forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Prompt m Contents
call = Contents -> StateT PromptEnv m Contents
forall {m :: * -> *}.
(MonadIO m, MonadFail m) =>
Contents -> StateT PromptEnv m Contents
loop []
  where
    loop :: Contents -> StateT PromptEnv m Contents
loop Contents
ret = do
      forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Prompt m ()
callPreHook @p
      Context
prev <- Prompt m Context
forall (m :: * -> *). (MonadIO m, MonadFail m) => Prompt m Context
getContext
      ((Contents
contents, FinishReason
finishReason), CreateChatCompletionResponse
res) <- IO ((Contents, FinishReason), CreateChatCompletionResponse)
-> StateT
     PromptEnv
     m
     ((Contents, FinishReason), CreateChatCompletionResponse)
forall a. IO a -> StateT PromptEnv m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ((Contents, FinishReason), CreateChatCompletionResponse)
 -> StateT
      PromptEnv
      m
      ((Contents, FinishReason), CreateChatCompletionResponse))
-> IO ((Contents, FinishReason), CreateChatCompletionResponse)
-> StateT
     PromptEnv
     m
     ((Contents, FinishReason), CreateChatCompletionResponse)
forall a b. (a -> b) -> a -> b
$ Text
-> CreateChatCompletionRequest
-> Contents
-> IO ((Contents, FinishReason), CreateChatCompletionResponse)
forall a.
ChatCompletion a =>
Text
-> CreateChatCompletionRequest
-> a
-> IO ((a, FinishReason), CreateChatCompletionResponse)
runRequest Context
prev.contextSessionName Context
prev.contextRequest (Context
prev.contextHeader Contents -> Contents -> Contents
forall a. Semigroup a => a -> a -> a
<> Context
prev.contextBody Contents -> Contents -> Contents
forall a. Semigroup a => a -> a -> a
<> Context
prev.contextFooter)
      let current_total_tokens :: Int
current_total_tokens = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ CompletionUsage -> Int
API.completionUsageTotalUnderscoretokens (CompletionUsage -> Int) -> Maybe CompletionUsage -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CreateChatCompletionResponse -> Maybe CompletionUsage
API.createChatCompletionResponseUsage CreateChatCompletionResponse
res
          next :: Context
next =
            Context
prev
              { contextResponse = Just res,
                contextTotalTokens = current_total_tokens
              }
      forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Context -> Prompt m ()
setContext @p Context
next
      forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Contents -> Prompt m ()
push @p Contents
contents
      forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Prompt m ()
callPostHook @p

      let ret' :: Contents
ret' = Contents
ret Contents -> Contents -> Contents
forall a. Semigroup a => a -> a -> a
<> Contents
contents

      case FinishReason
finishReason of
        FinishReason
Stop -> Contents -> StateT PromptEnv m Contents
forall a. a -> StateT PromptEnv m a
forall (m :: * -> *) a. Monad m => a -> m a
return Contents
ret'
        FinishReason
ToolCalls -> Context -> Contents -> Contents -> StateT PromptEnv m Contents
forall {m :: * -> *} {r}.
(MonadIO m, MonadFail m, HasField "contextSessionName" r Text) =>
r -> Contents -> Contents -> StateT PromptEnv m Contents
callTool Context
next Contents
contents Contents
ret'
        FinishReason
FunctionCall -> Context -> Contents -> Contents -> StateT PromptEnv m Contents
forall {m :: * -> *} {r}.
(MonadIO m, MonadFail m, HasField "contextSessionName" r Text) =>
r -> Contents -> Contents -> StateT PromptEnv m Contents
callTool Context
next Contents
contents Contents
ret'
        FinishReason
Length -> Contents -> StateT PromptEnv m Contents
loop Contents
ret'
        FinishReason
_ -> Contents -> StateT PromptEnv m Contents
forall a. a -> StateT PromptEnv m a
forall (m :: * -> *) a. Monad m => a -> m a
return Contents
ret'

    callTool :: r -> Contents -> Contents -> StateT PromptEnv m Contents
callTool r
next Contents
contents Contents
ret = do
      Contents -> StateT PromptEnv m ()
forall (m :: * -> *). MonadIO m => Contents -> m ()
showContents Contents
contents
      PromptEnv
env <- StateT PromptEnv m PromptEnv
forall (m :: * -> *) s. Monad m => StateT s m s
get
      Contents
retTool <- forall p (m :: * -> *).
(PersistentBackend p, MonadIO m, MonadFail m) =>
[ToolProxy] -> Text -> Contents -> Prompt m Contents
tryToolExec @p PromptEnv
env.tools r
next.contextSessionName Contents
contents
      Contents -> StateT PromptEnv m ()
forall (m :: * -> *). MonadIO m => Contents -> m ()
showContents Contents
retTool
      forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Contents -> Prompt m ()
pushToolReturn @p Contents
retTool
      Contents
v <- forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Prompt m Contents
call @p
      Contents -> StateT PromptEnv m Contents
forall a. a -> StateT PromptEnv m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Contents -> StateT PromptEnv m Contents)
-> Contents -> StateT PromptEnv m Contents
forall a b. (a -> b) -> a -> b
$ Contents
ret Contents -> Contents -> Contents
forall a. Semigroup a => a -> a -> a
<> Contents
retTool Contents -> Contents -> Contents
forall a. Semigroup a => a -> a -> a
<> Contents
v

callWithText :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => Text -> Prompt m Contents
callWithText :: forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Text -> Prompt m Contents
callWithText Text
input = do
  UTCTime
time <- IO UTCTime -> StateT PromptEnv m UTCTime
forall a. IO a -> StateT PromptEnv m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  Context
context <- Prompt m Context
forall (m :: * -> *). (MonadIO m, MonadFail m) => Prompt m Context
getContext
  let contents :: Contents
contents = [User -> Message -> Text -> UTCTime -> Content
Content User
User (Text -> Message
Message Text
input) Context
context.contextSessionName UTCTime
time]
  forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Contents -> Prompt m ()
push @p Contents
contents
  forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Prompt m Contents
call @p

callWithContents :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => Contents -> Prompt m Contents
callWithContents :: forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Contents -> Prompt m Contents
callWithContents Contents
input = do
  forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Contents -> Prompt m ()
push @p Contents
input
  forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Prompt m Contents
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)
  ) =>
  Contents ->
  Prompt m (Maybe validation)
callWithValidation :: forall validation p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p, Tool validation,
 FromJSON validation, FromJSON (Output validation),
 ToJSON validation, ToJSON (Output validation)) =>
Contents -> Prompt m (Maybe validation)
callWithValidation Contents
contents = do
  let valid :: ToolProxy
valid = Proxy validation -> ToolProxy
forall t.
(Tool t, FromJSON t, ToJSON t, FromJSON (Output t),
 ToJSON (Output t)) =>
Proxy t -> ToolProxy
ToolProxy (Proxy validation
forall {k} (t :: k). Proxy t
Proxy :: Proxy validation)
  case ToolProxy -> Contents -> Maybe Content
findToolCall ToolProxy
valid Contents
contents of
    Just (Content User
_ (ToolCall Text
_ Text
_ Text
args') Text
_ UTCTime
_) -> do
      let v :: Either String validation
v = (ByteString -> Either String validation
forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode (ByteString -> ByteString
BS.fromStrict (Text -> ByteString
T.encodeUtf8 Text
args')) :: Either String validation)
      case Either String validation
v of
        Left String
err -> do
          IO () -> StateT PromptEnv m ()
forall a. IO a -> StateT PromptEnv m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT PromptEnv m ()) -> IO () -> StateT PromptEnv m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
err
          Maybe validation -> Prompt m (Maybe validation)
forall a. a -> StateT PromptEnv m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe validation
forall a. Maybe a
Nothing
        Right validation
v' -> Maybe validation -> Prompt m (Maybe validation)
forall a. a -> StateT PromptEnv m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe validation -> Prompt m (Maybe validation))
-> Maybe validation -> Prompt m (Maybe validation)
forall a b. (a -> b) -> a -> b
$ validation -> Maybe validation
forall a. a -> Maybe a
Just validation
v'
    Maybe Content
_ -> Maybe validation -> Prompt m (Maybe validation)
forall a. a -> StateT PromptEnv m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe validation
forall a. Maybe a
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)
  ) =>
  [ToolProxy] ->
  [CustomInstructionProxy] ->
  Text ->
  API.CreateChatCompletionRequest ->
  Text ->
  m (Maybe validation)
runPromptWithValidation :: forall validation p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p, Tool validation,
 FromJSON validation, FromJSON (Output validation),
 ToJSON validation, ToJSON (Output validation)) =>
[ToolProxy]
-> [CustomInstructionProxy]
-> Text
-> CreateChatCompletionRequest
-> Text
-> m (Maybe validation)
runPromptWithValidation [ToolProxy]
tools [CustomInstructionProxy]
customs Text
sessionName CreateChatCompletionRequest
req Text
input = do
  let valid :: ToolProxy
valid = Proxy validation -> ToolProxy
forall t.
(Tool t, FromJSON t, ToJSON t, FromJSON (Output t),
 ToJSON (Output t)) =>
Proxy t -> ToolProxy
ToolProxy (Proxy validation
forall {k} (t :: k). Proxy t
Proxy :: Proxy validation)
  forall p (m :: * -> *) a.
(MonadIO m, MonadFail m, PersistentBackend p) =>
[ToolProxy]
-> [CustomInstructionProxy]
-> Text
-> CreateChatCompletionRequest
-> Prompt m a
-> m a
runPrompt @p (ToolProxy
valid ToolProxy -> [ToolProxy] -> [ToolProxy]
forall a. a -> [a] -> [a]
: [ToolProxy]
tools) [CustomInstructionProxy]
customs Text
sessionName CreateChatCompletionRequest
req (forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Text -> Prompt m Contents
callWithText @p Text
input Prompt m Contents
-> (Contents -> Prompt m (Maybe validation))
-> Prompt m (Maybe validation)
forall a b.
StateT PromptEnv m a
-> (a -> StateT PromptEnv m b) -> StateT PromptEnv m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall validation p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p, Tool validation,
 FromJSON validation, FromJSON (Output validation),
 ToJSON validation, ToJSON (Output validation)) =>
Contents -> Prompt m (Maybe validation)
callWithValidation @validation @p)

user :: Text -> Content
user :: Text -> Content
user Text
input = User -> Message -> Text -> UTCTime -> Content
Content User
User (Text -> Message
Message Text
input) Text
"default" UTCTime
defaultUTCTime

system :: Text -> Content
system :: Text -> Content
system Text
input = User -> Message -> Text -> UTCTime -> Content
Content User
System (Text -> Message
Message Text
input) Text
"default" UTCTime
defaultUTCTime

assistant :: Text -> Content
assistant :: Text -> Content
assistant Text
input = User -> Message -> Text -> UTCTime -> Content
Content User
Assistant (Text -> Message
Message Text
input) Text
"default" UTCTime
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 :: forall input output (m :: * -> *) p.
(MonadIO m, MonadFail m, p ~ StatelessConf, ToJSON input,
 FromJSON input, JSONSchema input, Tool output, FromJSON output,
 FromJSON (Output output), ToJSON output, ToJSON (Output output)) =>
Contents -> input -> m (Maybe output)
generate Contents
userContext input
input = do
  let valid :: ToolProxy
valid = Proxy output -> ToolProxy
forall t.
(Tool t, FromJSON t, ToJSON t, FromJSON (Output t),
 ToJSON (Output t)) =>
Proxy t -> ToolProxy
ToolProxy (Proxy output
forall {k} (t :: k). Proxy t
Proxy :: Proxy output)
      req :: CreateChatCompletionRequest
req = (Text -> CreateChatCompletionRequest
fromModel Text
"gpt-4")
  forall p (m :: * -> *) a.
(MonadIO m, MonadFail m, PersistentBackend p) =>
[ToolProxy]
-> [CustomInstructionProxy]
-> Text
-> CreateChatCompletionRequest
-> Prompt m a
-> m a
runPrompt @p [Item [ToolProxy]
ToolProxy
valid] [] Text
"default" CreateChatCompletionRequest
req (Prompt m (Maybe output) -> m (Maybe output))
-> Prompt m (Maybe output) -> m (Maybe output)
forall a b. (a -> b) -> a -> b
$ do
    UTCTime
time <- IO UTCTime -> StateT PromptEnv m UTCTime
forall a. IO a -> StateT PromptEnv m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    Context
context <- Prompt m Context
forall (m :: * -> *). (MonadIO m, MonadFail m) => Prompt m Context
getContext
    let schemaText :: Text
        schemaText :: Text
schemaText = ByteString -> Text
T.decodeUtf8Lenient (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ Schema -> Value
toAeson (forall r. JSONSchema r => Schema
schema @input)
        inputText :: Text
        inputText :: Text
inputText = ByteString -> Text
T.decodeUtf8Lenient (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ input -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode input
input
        contents :: Contents
contents = Contents
userContext Contents -> Contents -> Contents
forall a. [a] -> [a] -> [a]
++
          [ Text -> Content
user (Text
"#User-input format is as follows:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
schemaText)
          , Text -> Content
user (Text
"#User-input is as follows:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
inputText)
          , Text -> Content
user (Text
"#Save the processing results using " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall a. Tool a => Text
toolFunctionName @output Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" function")
          ]
    
    forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Contents -> Prompt m ()
push @p Contents
contents
    forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Prompt m Contents
call @p Prompt m Contents
-> (Contents -> Prompt m (Maybe output)) -> Prompt m (Maybe output)
forall a b.
StateT PromptEnv m a
-> (a -> StateT PromptEnv m b) -> StateT PromptEnv m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall validation p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p, Tool validation,
 FromJSON validation, FromJSON (Output validation),
 ToJSON validation, ToJSON (Output validation)) =>
Contents -> Prompt m (Maybe validation)
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
-> CreateChatCompletionRequest
-> m PromptEnv
initializePrompt [ToolProxy]
tools [CustomInstructionProxy]
customs Text
sessionName CreateChatCompletionRequest
req = do
  let settings :: CreateChatCompletionRequest
settings = [ToolProxy]
-> CreateChatCompletionRequest -> CreateChatCompletionRequest
addTools [ToolProxy]
tools (CreateChatCompletionRequest
req {API.createChatCompletionRequestTools = Nothing})
  forall p (m :: * -> *) a.
(MonadIO m, MonadFail m, PersistentBackend p) =>
(Conn p -> m a) -> m a
withDB @p ((Conn p -> m PromptEnv) -> m PromptEnv)
-> (Conn p -> m PromptEnv) -> m PromptEnv
forall a b. (a -> b) -> a -> b
$ \Conn p
conn -> do
    forall p (m :: * -> *).
(PersistentBackend p, MonadIO m, MonadFail m) =>
Conn p -> Text -> m (Maybe Context)
load @p Conn p
conn Text
sessionName m (Maybe Context) -> (Maybe Context -> m PromptEnv) -> m PromptEnv
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just Context
v ->
        PromptEnv -> m PromptEnv
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PromptEnv -> m PromptEnv) -> PromptEnv -> m PromptEnv
forall a b. (a -> b) -> a -> b
$
          PromptEnv
            { $sel:context:PromptEnv :: Context
context = Context
v,
              $sel:tools:PromptEnv :: [ToolProxy]
tools = [ToolProxy]
tools,
              $sel:customInstructions:PromptEnv :: [CustomInstructionProxy]
customInstructions = [CustomInstructionProxy]
customs,
              $sel:backend:PromptEnv :: PersistProxy
backend = (p -> PersistProxy
forall t. PersistentBackend t => t -> PersistProxy
PersistProxy (forall p. PersistentBackend p => p
config @p)),
              $sel:hooks:PromptEnv :: [HookProxy]
hooks = []
            }
      Maybe Context
Nothing -> do
        UTCTime
time <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
        let init' :: PromptEnv
init' =
              PromptEnv
                { $sel:context:PromptEnv :: Context
context =
                    Context
                      { $sel:contextRequest:Context :: CreateChatCompletionRequest
contextRequest = CreateChatCompletionRequest
settings,
                        $sel:contextResponse:Context :: Maybe CreateChatCompletionResponse
contextResponse = Maybe CreateChatCompletionResponse
forall a. Maybe a
Nothing,
                        $sel:contextHeader:Context :: Contents
contextHeader = [CustomInstructionProxy] -> Contents
headers [CustomInstructionProxy]
customs Contents -> Contents -> Contents
forall a. [a] -> [a] -> [a]
++ [ToolProxy] -> Contents
toolHeaders [ToolProxy]
tools,
                        $sel:contextBody:Context :: Contents
contextBody = [],
                        $sel:contextFooter:Context :: Contents
contextFooter = [ToolProxy] -> Contents
toolFooters [ToolProxy]
tools Contents -> Contents -> Contents
forall a. [a] -> [a] -> [a]
++ [CustomInstructionProxy] -> Contents
footers [CustomInstructionProxy]
customs,
                        $sel:contextTotalTokens:Context :: Int
contextTotalTokens = Int
0,
                        $sel:contextSessionName:Context :: Text
contextSessionName = Text
sessionName,
                        $sel:contextCreated:Context :: UTCTime
contextCreated = UTCTime
time
                      },
                  $sel:tools:PromptEnv :: [ToolProxy]
tools = [ToolProxy]
tools,
                  $sel:customInstructions:PromptEnv :: [CustomInstructionProxy]
customInstructions = [CustomInstructionProxy]
customs,
                  $sel:backend:PromptEnv :: PersistProxy
backend = (p -> PersistProxy
forall t. PersistentBackend t => t -> PersistProxy
PersistProxy (forall p. PersistentBackend p => p
config @p)),
                  $sel:hooks:PromptEnv :: [HookProxy]
hooks = []
                }
        forall p (m :: * -> *).
(PersistentBackend p, MonadIO m, MonadFail m) =>
Conn p -> Context -> m ()
initialize @p Conn p
conn (PromptEnv
init'.context)
        PromptEnv -> m PromptEnv
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PromptEnv
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
-> CreateChatCompletionRequest
-> Prompt m a
-> m a
runPrompt [ToolProxy]
tools [CustomInstructionProxy]
customs Text
sessionName CreateChatCompletionRequest
req Prompt m a
func = do
  PromptEnv
context <- forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
[ToolProxy]
-> [CustomInstructionProxy]
-> Text
-> CreateChatCompletionRequest
-> m PromptEnv
initializePrompt @p [ToolProxy]
tools [CustomInstructionProxy]
customs Text
sessionName CreateChatCompletionRequest
req
  (a, PromptEnv) -> a
forall a b. (a, b) -> a
fst ((a, PromptEnv) -> a) -> m (a, PromptEnv) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Prompt m a -> PromptEnv -> m (a, PromptEnv)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Prompt m a
func PromptEnv
context

instance ChatCompletion Contents where
  toRequest :: CreateChatCompletionRequest
-> Contents -> CreateChatCompletionRequest
toRequest CreateChatCompletionRequest
orgRequest Contents
contents =
    let messages :: [ChatCompletionRequestMessage]
messages = ((Content -> ChatCompletionRequestMessage)
 -> Contents -> [ChatCompletionRequestMessage])
-> Contents
-> (Content -> ChatCompletionRequestMessage)
-> [ChatCompletionRequestMessage]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Content -> ChatCompletionRequestMessage)
-> Contents -> [ChatCompletionRequestMessage]
forall a b. (a -> b) -> [a] -> [b]
map Contents
contents ((Content -> ChatCompletionRequestMessage)
 -> [ChatCompletionRequestMessage])
-> (Content -> ChatCompletionRequestMessage)
-> [ChatCompletionRequestMessage]
forall a b. (a -> b) -> a -> b
$ \case
          Content User
user (Message Text
message) Text
_ UTCTime
_ ->
            API.ChatCompletionRequestMessage
              { chatCompletionRequestMessageContent :: Maybe ChatCompletionRequestMessageContent
API.chatCompletionRequestMessageContent = ChatCompletionRequestMessageContent
-> Maybe ChatCompletionRequestMessageContent
forall a. a -> Maybe a
Just (ChatCompletionRequestMessageContent
 -> Maybe ChatCompletionRequestMessageContent)
-> ChatCompletionRequestMessageContent
-> Maybe ChatCompletionRequestMessageContent
forall a b. (a -> b) -> a -> b
$ Text -> ChatCompletionRequestMessageContent
API.ChatCompletionRequestMessageContentText Text
message,
                chatCompletionRequestMessageRole :: Text
API.chatCompletionRequestMessageRole = User -> Text
userToText User
user,
                chatCompletionRequestMessageName :: Maybe Text
API.chatCompletionRequestMessageName = Maybe Text
forall a. Maybe a
Nothing,
                chatCompletionRequestMessageToolUnderscorecalls :: Maybe [ChatCompletionMessageToolCall]
API.chatCompletionRequestMessageToolUnderscorecalls = Maybe [ChatCompletionMessageToolCall]
forall a. Maybe a
Nothing,
                chatCompletionRequestMessageFunctionUnderscorecall :: Maybe ChatCompletionRequestAssistantMessageFunctionCall
API.chatCompletionRequestMessageFunctionUnderscorecall = Maybe ChatCompletionRequestAssistantMessageFunctionCall
forall a. Maybe a
Nothing,
                chatCompletionRequestMessageToolUnderscorecallUnderscoreid :: Maybe Text
API.chatCompletionRequestMessageToolUnderscorecallUnderscoreid = Maybe Text
forall a. Maybe a
Nothing
              }
          Content User
user (Image Text
type' Text
img) Text
_ UTCTime
_ ->
            API.ChatCompletionRequestMessage
              { chatCompletionRequestMessageContent :: Maybe ChatCompletionRequestMessageContent
API.chatCompletionRequestMessageContent =
                  ChatCompletionRequestMessageContent
-> Maybe ChatCompletionRequestMessageContent
forall a. a -> Maybe a
Just (ChatCompletionRequestMessageContent
 -> Maybe ChatCompletionRequestMessageContent)
-> ChatCompletionRequestMessageContent
-> Maybe ChatCompletionRequestMessageContent
forall a b. (a -> b) -> a -> b
$
                    [ChatCompletionRequestMessageContentPart]
-> ChatCompletionRequestMessageContent
API.ChatCompletionRequestMessageContentParts
                      [ API.ChatCompletionRequestMessageContentPart
                          { chatCompletionRequestMessageContentPartType :: Text
API.chatCompletionRequestMessageContentPartType = Text
"image_url",
                            chatCompletionRequestMessageContentPartText :: Maybe Text
API.chatCompletionRequestMessageContentPartText = Maybe Text
forall a. Maybe a
Nothing,
                            chatCompletionRequestMessageContentPartImageUnderscoreurl :: Maybe ChatCompletionRequestMessageContentPartImageImageUrl
API.chatCompletionRequestMessageContentPartImageUnderscoreurl =
                              ChatCompletionRequestMessageContentPartImageImageUrl
-> Maybe ChatCompletionRequestMessageContentPartImageImageUrl
forall a. a -> Maybe a
Just (ChatCompletionRequestMessageContentPartImageImageUrl
 -> Maybe ChatCompletionRequestMessageContentPartImageImageUrl)
-> ChatCompletionRequestMessageContentPartImageImageUrl
-> Maybe ChatCompletionRequestMessageContentPartImageImageUrl
forall a b. (a -> b) -> a -> b
$
                                API.ChatCompletionRequestMessageContentPartImageImageUrl
                                  { chatCompletionRequestMessageContentPartImageImageUrlUrl :: Text
API.chatCompletionRequestMessageContentPartImageImageUrlUrl =
                                      Text
"data:image/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
type' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";base64," Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
img,
                                    chatCompletionRequestMessageContentPartImageImageUrlDetail :: Maybe Text
API.chatCompletionRequestMessageContentPartImageImageUrlDetail = Maybe Text
forall a. Maybe a
Nothing
                                  }
                          }
                      ],
                chatCompletionRequestMessageRole :: Text
API.chatCompletionRequestMessageRole = User -> Text
userToText User
user,
                chatCompletionRequestMessageName :: Maybe Text
API.chatCompletionRequestMessageName = Maybe Text
forall a. Maybe a
Nothing,
                chatCompletionRequestMessageToolUnderscorecalls :: Maybe [ChatCompletionMessageToolCall]
API.chatCompletionRequestMessageToolUnderscorecalls = Maybe [ChatCompletionMessageToolCall]
forall a. Maybe a
Nothing,
                chatCompletionRequestMessageFunctionUnderscorecall :: Maybe ChatCompletionRequestAssistantMessageFunctionCall
API.chatCompletionRequestMessageFunctionUnderscorecall = Maybe ChatCompletionRequestAssistantMessageFunctionCall
forall a. Maybe a
Nothing,
                chatCompletionRequestMessageToolUnderscorecallUnderscoreid :: Maybe Text
API.chatCompletionRequestMessageToolUnderscorecallUnderscoreid = Maybe Text
forall a. Maybe a
Nothing
              }
          Content User
user (ToolCall Text
id' Text
name' Text
args') Text
_ UTCTime
_ ->
            API.ChatCompletionRequestMessage
              { chatCompletionRequestMessageContent :: Maybe ChatCompletionRequestMessageContent
API.chatCompletionRequestMessageContent = Maybe ChatCompletionRequestMessageContent
forall a. Maybe a
Nothing,
                chatCompletionRequestMessageRole :: Text
API.chatCompletionRequestMessageRole = User -> Text
userToText User
user,
                chatCompletionRequestMessageName :: Maybe Text
API.chatCompletionRequestMessageName = Maybe Text
forall a. Maybe a
Nothing,
                chatCompletionRequestMessageToolUnderscorecalls :: Maybe [ChatCompletionMessageToolCall]
API.chatCompletionRequestMessageToolUnderscorecalls =
                  [ChatCompletionMessageToolCall]
-> Maybe [ChatCompletionMessageToolCall]
forall a. a -> Maybe a
Just
                    [ API.ChatCompletionMessageToolCall
                        { chatCompletionMessageToolCallId :: Text
API.chatCompletionMessageToolCallId = Text
id',
                          chatCompletionMessageToolCallType :: Text
API.chatCompletionMessageToolCallType = Text
"function",
                          chatCompletionMessageToolCallFunction :: ChatCompletionMessageToolCallFunction
API.chatCompletionMessageToolCallFunction =
                            API.ChatCompletionMessageToolCallFunction
                              { chatCompletionMessageToolCallFunctionName :: Text
API.chatCompletionMessageToolCallFunctionName = Text
name',
                                chatCompletionMessageToolCallFunctionArguments :: Text
API.chatCompletionMessageToolCallFunctionArguments = Text
args'
                              }
                        }
                    ],
                chatCompletionRequestMessageFunctionUnderscorecall :: Maybe ChatCompletionRequestAssistantMessageFunctionCall
API.chatCompletionRequestMessageFunctionUnderscorecall = Maybe ChatCompletionRequestAssistantMessageFunctionCall
forall a. Maybe a
Nothing,
                chatCompletionRequestMessageToolUnderscorecallUnderscoreid :: Maybe Text
API.chatCompletionRequestMessageToolUnderscorecallUnderscoreid = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
id'
              }
          Content User
user (ToolReturn Text
id' Text
name' Text
ret') Text
_ UTCTime
_ ->
            API.ChatCompletionRequestMessage
              { chatCompletionRequestMessageContent :: Maybe ChatCompletionRequestMessageContent
API.chatCompletionRequestMessageContent = ChatCompletionRequestMessageContent
-> Maybe ChatCompletionRequestMessageContent
forall a. a -> Maybe a
Just (ChatCompletionRequestMessageContent
 -> Maybe ChatCompletionRequestMessageContent)
-> ChatCompletionRequestMessageContent
-> Maybe ChatCompletionRequestMessageContent
forall a b. (a -> b) -> a -> b
$ Text -> ChatCompletionRequestMessageContent
API.ChatCompletionRequestMessageContentText Text
ret',
                chatCompletionRequestMessageRole :: Text
API.chatCompletionRequestMessageRole = User -> Text
userToText User
user,
                chatCompletionRequestMessageName :: Maybe Text
API.chatCompletionRequestMessageName = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name',
                chatCompletionRequestMessageToolUnderscorecalls :: Maybe [ChatCompletionMessageToolCall]
API.chatCompletionRequestMessageToolUnderscorecalls = Maybe [ChatCompletionMessageToolCall]
forall a. Maybe a
Nothing,
                chatCompletionRequestMessageFunctionUnderscorecall :: Maybe ChatCompletionRequestAssistantMessageFunctionCall
API.chatCompletionRequestMessageFunctionUnderscorecall = Maybe ChatCompletionRequestAssistantMessageFunctionCall
forall a. Maybe a
Nothing,
                chatCompletionRequestMessageToolUnderscorecallUnderscoreid :: Maybe Text
API.chatCompletionRequestMessageToolUnderscorecallUnderscoreid = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
id'
              }
     in CreateChatCompletionRequest
orgRequest {API.createChatCompletionRequestMessages = messages}
  fromResponse :: Text -> CreateChatCompletionResponse -> (Contents, FinishReason)
fromResponse Text
sessionName CreateChatCompletionResponse
response =
    let res :: CreateChatCompletionResponseChoicesInner
res = [CreateChatCompletionResponseChoicesInner]
-> CreateChatCompletionResponseChoicesInner
forall a. HasCallStack => [a] -> a
head (CreateChatCompletionResponse
-> [CreateChatCompletionResponseChoicesInner]
API.createChatCompletionResponseChoices CreateChatCompletionResponse
response)
        message :: ChatCompletionResponseMessage
message = CreateChatCompletionResponseChoicesInner
-> ChatCompletionResponseMessage
API.createChatCompletionResponseChoicesInnerMessage CreateChatCompletionResponseChoicesInner
res
        role :: User
role = Text -> User
textToUser (Text -> User) -> Text -> User
forall a b. (a -> b) -> a -> b
$ ChatCompletionResponseMessage -> Text
API.chatCompletionResponseMessageRole ChatCompletionResponseMessage
message
        content :: Maybe Text
content = ChatCompletionResponseMessage -> Maybe Text
API.chatCompletionResponseMessageContent ChatCompletionResponseMessage
message
        finishReason :: FinishReason
finishReason = Text -> FinishReason
textToFinishReason (Text -> FinishReason) -> Text -> FinishReason
forall a b. (a -> b) -> a -> b
$ CreateChatCompletionResponseChoicesInner -> Text
API.createChatCompletionResponseChoicesInnerFinishUnderscorereason CreateChatCompletionResponseChoicesInner
res
        v :: Contents
v = case ChatCompletionResponseMessage
-> Maybe [ChatCompletionMessageToolCall]
API.chatCompletionResponseMessageToolUnderscorecalls ChatCompletionResponseMessage
message of
          Just [ChatCompletionMessageToolCall]
toolcalls -> (ChatCompletionMessageToolCall -> Content)
-> [ChatCompletionMessageToolCall] -> Contents
forall a b. (a -> b) -> [a] -> [b]
map (\(API.ChatCompletionMessageToolCall Text
id' Text
_ (API.ChatCompletionMessageToolCallFunction Text
name' Text
args')) -> User -> Message -> Text -> UTCTime -> Content
Content User
role (Text -> Text -> Text -> Message
ToolCall Text
id' Text
name' Text
args') Text
sessionName UTCTime
defaultUTCTime) [ChatCompletionMessageToolCall]
toolcalls
          Maybe [ChatCompletionMessageToolCall]
Nothing -> [User -> Message -> Text -> UTCTime -> Content
Content User
role (Text -> Message
Message (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
content)) Text
sessionName UTCTime
defaultUTCTime]
     in (Contents
v, FinishReason
finishReason)

runRequest :: (ChatCompletion a) => Text -> API.CreateChatCompletionRequest -> a -> IO ((a, FinishReason), API.CreateChatCompletionResponse)
runRequest :: forall a.
ChatCompletion a =>
Text
-> CreateChatCompletionRequest
-> a
-> IO ((a, FinishReason), CreateChatCompletionResponse)
runRequest Text
sessionName CreateChatCompletionRequest
defaultReq a
request = do
  AuthClient
api_key <- (Text -> AuthClient
API.clientAuth (Text -> AuthClient) -> (String -> Text) -> String -> AuthClient
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) (String -> AuthClient) -> IO String -> IO AuthClient
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
getEnv String
"OPENAI_API_KEY"
  BaseUrl
url <- do
    String -> IO (Maybe String)
lookupEnv String
"OPENAI_ENDPOINT" IO (Maybe String) -> (Maybe String -> IO BaseUrl) -> IO BaseUrl
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just String
url -> String -> IO BaseUrl
forall (m :: * -> *). MonadThrow m => String -> m BaseUrl
parseBaseUrl String
url
      Maybe String
Nothing -> String -> IO BaseUrl
forall (m :: * -> *). MonadThrow m => String -> m BaseUrl
parseBaseUrl String
"https://api.openai.com/v1/"
  Manager
manager <-
    ManagerSettings -> IO Manager
newManager
      ( ManagerSettings
tlsManagerSettings
          { managerResponseTimeout = responseTimeoutMicro (120 * 1000 * 1000)
          }
      )
  let API.OpenAIBackend {AuthClient -> OpenAIClient ListModelsResponse
AuthClient
-> Maybe Int
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> OpenAIClient ListAssistantsResponse
AuthClient -> Maybe Text -> OpenAIClient ListFilesResponse
AuthClient
-> Maybe Text
-> Maybe Int
-> OpenAIClient ListPaginatedFineTuningJobsResponse
AuthClient -> Text -> OpenAIClient Text
AuthClient -> Text -> OpenAIClient ThreadObject
AuthClient -> Text -> OpenAIClient OpenAIFile
AuthClient -> Text -> OpenAIClient Model
AuthClient -> Text -> OpenAIClient FineTuningJob
AuthClient -> Text -> OpenAIClient DeleteThreadResponse
AuthClient -> Text -> OpenAIClient DeleteModelResponse
AuthClient -> Text -> OpenAIClient DeleteFileResponse
AuthClient -> Text -> OpenAIClient DeleteAssistantResponse
AuthClient -> Text -> OpenAIClient AssistantObject
AuthClient
-> Text
-> Maybe Int
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> OpenAIClient ListRunsResponse
AuthClient
-> Text
-> Maybe Int
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> OpenAIClient ListMessagesResponse
AuthClient
-> Text
-> Maybe Int
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> OpenAIClient ListAssistantFilesResponse
AuthClient
-> Text
-> Maybe Text
-> Maybe Int
-> OpenAIClient ListFineTuningJobEventsResponse
AuthClient -> Text -> Text -> OpenAIClient RunObject
AuthClient -> Text -> Text -> OpenAIClient MessageObject
AuthClient
-> Text -> Text -> OpenAIClient DeleteAssistantFileResponse
AuthClient -> Text -> Text -> OpenAIClient AssistantFileObject
AuthClient
-> Text
-> Text
-> Maybe Int
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> OpenAIClient ListRunStepsResponse
AuthClient
-> Text
-> Text
-> Maybe Int
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> OpenAIClient ListMessageFilesResponse
AuthClient -> Text -> Text -> Text -> OpenAIClient RunStepObject
AuthClient
-> Text -> Text -> Text -> OpenAIClient MessageFileObject
AuthClient
-> Text
-> Text
-> SubmitToolOutputsRunRequest
-> OpenAIClient RunObject
AuthClient
-> Text -> Text -> ModifyRunRequest -> OpenAIClient RunObject
AuthClient
-> Text
-> Text
-> ModifyMessageRequest
-> OpenAIClient MessageObject
AuthClient
-> Text -> ModifyThreadRequest -> OpenAIClient ThreadObject
AuthClient
-> Text -> ModifyAssistantRequest -> OpenAIClient AssistantObject
AuthClient -> Text -> CreateRunRequest -> OpenAIClient RunObject
AuthClient
-> Text -> CreateMessageRequest -> OpenAIClient MessageObject
AuthClient
-> Text
-> CreateAssistantFileRequest
-> OpenAIClient AssistantFileObject
AuthClient -> CreateThreadRequest -> OpenAIClient ThreadObject
AuthClient -> CreateThreadAndRunRequest -> OpenAIClient RunObject
AuthClient -> CreateSpeechRequest -> OpenAIClient ByteString
AuthClient
-> CreateModerationRequest -> OpenAIClient CreateModerationResponse
AuthClient -> CreateImageRequest -> OpenAIClient ImagesResponse
AuthClient
-> CreateFineTuningJobRequest -> OpenAIClient FineTuningJob
AuthClient
-> CreateEmbeddingRequest -> OpenAIClient CreateEmbeddingResponse
AuthClient
-> CreateCompletionRequest -> OpenAIClient CreateCompletionResponse
AuthClient
-> CreateChatCompletionRequest
-> OpenAIClient CreateChatCompletionResponse
AuthClient
-> CreateAssistantRequest -> OpenAIClient AssistantObject
AuthClient -> FormCreateFile -> OpenAIClient OpenAIFile
AuthClient -> FormCreateImageEdit -> OpenAIClient ImagesResponse
AuthClient
-> FormCreateImageVariation -> OpenAIClient ImagesResponse
AuthClient
-> FormCreateTranscription
-> OpenAIClient CreateTranscription200Response
AuthClient
-> FormCreateTranslation
-> OpenAIClient CreateTranslation200Response
cancelRun :: AuthClient -> Text -> Text -> OpenAIClient RunObject
createAssistant :: AuthClient
-> CreateAssistantRequest -> OpenAIClient AssistantObject
createAssistantFile :: AuthClient
-> Text
-> CreateAssistantFileRequest
-> OpenAIClient AssistantFileObject
createMessage :: AuthClient
-> Text -> CreateMessageRequest -> OpenAIClient MessageObject
createRun :: AuthClient -> Text -> CreateRunRequest -> OpenAIClient RunObject
createThread :: AuthClient -> CreateThreadRequest -> OpenAIClient ThreadObject
createThreadAndRun :: AuthClient -> CreateThreadAndRunRequest -> OpenAIClient RunObject
deleteAssistant :: AuthClient -> Text -> OpenAIClient DeleteAssistantResponse
deleteAssistantFile :: AuthClient
-> Text -> Text -> OpenAIClient DeleteAssistantFileResponse
deleteThread :: AuthClient -> Text -> OpenAIClient DeleteThreadResponse
getAssistant :: AuthClient -> Text -> OpenAIClient AssistantObject
getAssistantFile :: AuthClient -> Text -> Text -> OpenAIClient AssistantFileObject
getMessage :: AuthClient -> Text -> Text -> OpenAIClient MessageObject
getMessageFile :: AuthClient
-> Text -> Text -> Text -> OpenAIClient MessageFileObject
getRun :: AuthClient -> Text -> Text -> OpenAIClient RunObject
getRunStep :: AuthClient -> Text -> Text -> Text -> OpenAIClient RunStepObject
getThread :: AuthClient -> Text -> OpenAIClient ThreadObject
listAssistantFiles :: AuthClient
-> Text
-> Maybe Int
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> OpenAIClient ListAssistantFilesResponse
listAssistants :: AuthClient
-> Maybe Int
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> OpenAIClient ListAssistantsResponse
listMessageFiles :: AuthClient
-> Text
-> Text
-> Maybe Int
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> OpenAIClient ListMessageFilesResponse
listMessages :: AuthClient
-> Text
-> Maybe Int
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> OpenAIClient ListMessagesResponse
listRunSteps :: AuthClient
-> Text
-> Text
-> Maybe Int
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> OpenAIClient ListRunStepsResponse
listRuns :: AuthClient
-> Text
-> Maybe Int
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> OpenAIClient ListRunsResponse
modifyAssistant :: AuthClient
-> Text -> ModifyAssistantRequest -> OpenAIClient AssistantObject
modifyMessage :: AuthClient
-> Text
-> Text
-> ModifyMessageRequest
-> OpenAIClient MessageObject
modifyRun :: AuthClient
-> Text -> Text -> ModifyRunRequest -> OpenAIClient RunObject
modifyThread :: AuthClient
-> Text -> ModifyThreadRequest -> OpenAIClient ThreadObject
submitToolOuputsToRun :: AuthClient
-> Text
-> Text
-> SubmitToolOutputsRunRequest
-> OpenAIClient RunObject
createSpeech :: AuthClient -> CreateSpeechRequest -> OpenAIClient ByteString
createTranscription :: AuthClient
-> FormCreateTranscription
-> OpenAIClient CreateTranscription200Response
createTranslation :: AuthClient
-> FormCreateTranslation
-> OpenAIClient CreateTranslation200Response
createChatCompletion :: AuthClient
-> CreateChatCompletionRequest
-> OpenAIClient CreateChatCompletionResponse
createCompletion :: AuthClient
-> CreateCompletionRequest -> OpenAIClient CreateCompletionResponse
createEmbedding :: AuthClient
-> CreateEmbeddingRequest -> OpenAIClient CreateEmbeddingResponse
createFile :: AuthClient -> FormCreateFile -> OpenAIClient OpenAIFile
deleteFile :: AuthClient -> Text -> OpenAIClient DeleteFileResponse
downloadFile :: AuthClient -> Text -> OpenAIClient Text
listFiles :: AuthClient -> Maybe Text -> OpenAIClient ListFilesResponse
retrieveFile :: AuthClient -> Text -> OpenAIClient OpenAIFile
cancelFineTuningJob :: AuthClient -> Text -> OpenAIClient FineTuningJob
createFineTuningJob :: AuthClient
-> CreateFineTuningJobRequest -> OpenAIClient FineTuningJob
listFineTuningEvents :: AuthClient
-> Text
-> Maybe Text
-> Maybe Int
-> OpenAIClient ListFineTuningJobEventsResponse
listPaginatedFineTuningJobs :: AuthClient
-> Maybe Text
-> Maybe Int
-> OpenAIClient ListPaginatedFineTuningJobsResponse
retrieveFineTuningJob :: AuthClient -> Text -> OpenAIClient FineTuningJob
createImage :: AuthClient -> CreateImageRequest -> OpenAIClient ImagesResponse
createImageEdit :: AuthClient -> FormCreateImageEdit -> OpenAIClient ImagesResponse
createImageVariation :: AuthClient
-> FormCreateImageVariation -> OpenAIClient ImagesResponse
deleteModel :: AuthClient -> Text -> OpenAIClient DeleteModelResponse
listModels :: AuthClient -> OpenAIClient ListModelsResponse
retrieveModel :: AuthClient -> Text -> OpenAIClient Model
createModeration :: AuthClient
-> CreateModerationRequest -> OpenAIClient CreateModerationResponse
$sel:cancelRun:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m -> a -> Text -> Text -> m RunObject
$sel:createAssistant:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a -> CreateAssistantRequest -> m AssistantObject
$sel:createAssistantFile:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a -> Text -> CreateAssistantFileRequest -> m AssistantFileObject
$sel:createMessage:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a -> Text -> CreateMessageRequest -> m MessageObject
$sel:createRun:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m -> a -> Text -> CreateRunRequest -> m RunObject
$sel:createThread:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m -> a -> CreateThreadRequest -> m ThreadObject
$sel:createThreadAndRun:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m -> a -> CreateThreadAndRunRequest -> m RunObject
$sel:deleteAssistant:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m -> a -> Text -> m DeleteAssistantResponse
$sel:deleteAssistantFile:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a -> Text -> Text -> m DeleteAssistantFileResponse
$sel:deleteThread:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m -> a -> Text -> m DeleteThreadResponse
$sel:getAssistant:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m -> a -> Text -> m AssistantObject
$sel:getAssistantFile:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m -> a -> Text -> Text -> m AssistantFileObject
$sel:getMessage:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m -> a -> Text -> Text -> m MessageObject
$sel:getMessageFile:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a -> Text -> Text -> Text -> m MessageFileObject
$sel:getRun:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m -> a -> Text -> Text -> m RunObject
$sel:getRunStep:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m -> a -> Text -> Text -> Text -> m RunStepObject
$sel:getThread:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m -> a -> Text -> m ThreadObject
$sel:listAssistantFiles:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a
-> Text
-> Maybe Int
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> m ListAssistantFilesResponse
$sel:listAssistants:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a
-> Maybe Int
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> m ListAssistantsResponse
$sel:listMessageFiles:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a
-> Text
-> Text
-> Maybe Int
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> m ListMessageFilesResponse
$sel:listMessages:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a
-> Text
-> Maybe Int
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> m ListMessagesResponse
$sel:listRunSteps:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a
-> Text
-> Text
-> Maybe Int
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> m ListRunStepsResponse
$sel:listRuns:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a
-> Text
-> Maybe Int
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> m ListRunsResponse
$sel:modifyAssistant:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a -> Text -> ModifyAssistantRequest -> m AssistantObject
$sel:modifyMessage:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a -> Text -> Text -> ModifyMessageRequest -> m MessageObject
$sel:modifyRun:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a -> Text -> Text -> ModifyRunRequest -> m RunObject
$sel:modifyThread:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a -> Text -> ModifyThreadRequest -> m ThreadObject
$sel:submitToolOuputsToRun:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a -> Text -> Text -> SubmitToolOutputsRunRequest -> m RunObject
$sel:createSpeech:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m -> a -> CreateSpeechRequest -> m ByteString
$sel:createTranscription:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a -> FormCreateTranscription -> m CreateTranscription200Response
$sel:createTranslation:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a -> FormCreateTranslation -> m CreateTranslation200Response
$sel:createChatCompletion:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a
-> CreateChatCompletionRequest
-> m CreateChatCompletionResponse
$sel:createCompletion:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a -> CreateCompletionRequest -> m CreateCompletionResponse
$sel:createEmbedding:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a -> CreateEmbeddingRequest -> m CreateEmbeddingResponse
$sel:createFile:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m -> a -> FormCreateFile -> m OpenAIFile
$sel:deleteFile:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m -> a -> Text -> m DeleteFileResponse
$sel:downloadFile:OpenAIBackend :: forall a (m :: * -> *). OpenAIBackend a m -> a -> Text -> m Text
$sel:listFiles:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m -> a -> Maybe Text -> m ListFilesResponse
$sel:retrieveFile:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m -> a -> Text -> m OpenAIFile
$sel:cancelFineTuningJob:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m -> a -> Text -> m FineTuningJob
$sel:createFineTuningJob:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a -> CreateFineTuningJobRequest -> m FineTuningJob
$sel:listFineTuningEvents:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a
-> Text
-> Maybe Text
-> Maybe Int
-> m ListFineTuningJobEventsResponse
$sel:listPaginatedFineTuningJobs:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a
-> Maybe Text
-> Maybe Int
-> m ListPaginatedFineTuningJobsResponse
$sel:retrieveFineTuningJob:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m -> a -> Text -> m FineTuningJob
$sel:createImage:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m -> a -> CreateImageRequest -> m ImagesResponse
$sel:createImageEdit:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m -> a -> FormCreateImageEdit -> m ImagesResponse
$sel:createImageVariation:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a -> FormCreateImageVariation -> m ImagesResponse
$sel:deleteModel:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m -> a -> Text -> m DeleteModelResponse
$sel:listModels:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m -> a -> m ListModelsResponse
$sel:retrieveModel:OpenAIBackend :: forall a (m :: * -> *). OpenAIBackend a m -> a -> Text -> m Model
$sel:createModeration:OpenAIBackend :: forall a (m :: * -> *).
OpenAIBackend a m
-> a -> CreateModerationRequest -> m CreateModerationResponse
..} = OpenAIBackend AuthClient OpenAIClient
API.createOpenAIClient
      req :: CreateChatCompletionRequest
req = (CreateChatCompletionRequest -> a -> CreateChatCompletionRequest
forall a.
ChatCompletion a =>
CreateChatCompletionRequest -> a -> CreateChatCompletionRequest
toRequest CreateChatCompletionRequest
defaultReq a
request)

  String -> IO (Maybe String)
lookupEnv String
"OPENAI_DEBUG" IO (Maybe String) -> (Maybe String -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just String
"1" -> do
      IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        ByteString -> IO ()
BS.putStr (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ CreateChatCompletionRequest -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty CreateChatCompletionRequest
req
        Text -> IO ()
T.putStrLn Text
""
    Maybe String
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  CreateChatCompletionResponse
res <- ClientEnv
-> OpenAIClient CreateChatCompletionResponse
-> IO CreateChatCompletionResponse
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
ClientEnv -> OpenAIClient a -> m a
API.callOpenAI (Manager -> BaseUrl -> ClientEnv
mkClientEnv Manager
manager BaseUrl
url) (OpenAIClient CreateChatCompletionResponse
 -> IO CreateChatCompletionResponse)
-> OpenAIClient CreateChatCompletionResponse
-> IO CreateChatCompletionResponse
forall a b. (a -> b) -> a -> b
$ AuthClient
-> CreateChatCompletionRequest
-> OpenAIClient CreateChatCompletionResponse
createChatCompletion AuthClient
api_key CreateChatCompletionRequest
req
  ((a, FinishReason), CreateChatCompletionResponse)
-> IO ((a, FinishReason), CreateChatCompletionResponse)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> CreateChatCompletionResponse -> (a, FinishReason)
forall a.
ChatCompletion a =>
Text -> CreateChatCompletionResponse -> (a, FinishReason)
fromResponse Text
sessionName CreateChatCompletionResponse
res, CreateChatCompletionResponse
res)

showContents :: (MonadIO m) => Contents -> m ()
showContents :: forall (m :: * -> *). MonadIO m => Contents -> m ()
showContents Contents
res = do
  Contents -> (Content -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Contents
res ((Content -> m ()) -> m ()) -> (Content -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(Content User
user Message
message Text
_ UTCTime
_) ->
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
      Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
        User -> Text
userToText User
user
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> case Message
message of
            Message Text
t -> Text
t
            Image Text
_ Text
_ -> Text
"Image: ..."
            c :: Message
c@(ToolCall Text
_ Text
_ Text
_) -> String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Message -> String
forall a. Show a => a -> String
show Message
c
            c :: Message
c@(ToolReturn Text
_ Text
_ Text
_) -> String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Message -> String
forall a. Show a => a -> String
show Message
c

fromModel :: Text -> API.CreateChatCompletionRequest
fromModel :: Text -> CreateChatCompletionRequest
fromModel Text
model =
  CreateChatCompletionRequest
defaultRequest
    { API.createChatCompletionRequestModel = API.CreateChatCompletionRequestModel model
    }

clear :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => Prompt m ()
clear :: forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Prompt m ()
clear = do
  Context
prev <- Prompt m Context
forall (m :: * -> *). (MonadIO m, MonadFail m) => Prompt m Context
getContext
  forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Context -> Prompt m ()
setContext @p (Context -> Prompt m ()) -> Context -> Prompt m ()
forall a b. (a -> b) -> a -> b
$ Context
prev {contextBody = []}

callWithImage :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => Text -> Prompt m Contents
callWithImage :: forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Text -> Prompt m Contents
callWithImage Text
imagePath = do
  let tryReadFile :: IO Text
tryReadFile = ByteString -> Text
T.decodeUtf8Lenient (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64.encode (ByteString -> Text) -> IO ByteString -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile (Text -> String
T.unpack Text
imagePath)
      imageType :: Text
imageType =
        if Text -> Text -> Bool
T.isSuffixOf Text
".png" Text
imagePath
          then Text
"png"
          else
            if Text -> Text -> Bool
T.isSuffixOf Text
".jpg" Text
imagePath Bool -> Bool -> Bool
|| Text -> Text -> Bool
T.isSuffixOf Text
".jpeg" Text
imagePath
              then Text
"jpeg"
              else Text
"jpeg"
  Text
file <- IO Text -> StateT PromptEnv m Text
forall a. IO a -> StateT PromptEnv m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> StateT PromptEnv m Text)
-> IO Text -> StateT PromptEnv m Text
forall a b. (a -> b) -> a -> b
$ IO Text
tryReadFile
  UTCTime
time <- IO UTCTime -> StateT PromptEnv m UTCTime
forall a. IO a -> StateT PromptEnv m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  Context
context <- Prompt m Context
forall (m :: * -> *). (MonadIO m, MonadFail m) => Prompt m Context
getContext
  let contents' :: Contents
contents' = [User -> Message -> Text -> UTCTime -> Content
Content User
User (Text -> Text -> Message
Image Text
imageType Text
file) Context
context.contextSessionName UTCTime
time]
  forall p (m :: * -> *).
(MonadIO m, MonadFail m, PersistentBackend p) =>
Contents -> Prompt m Contents
callWithContents @p Contents
contents'