packages feed

intelli-monad (empty) → 0.1.0.0

raw patch · 18 files changed

+1961/−0 lines, 18 filesdep +JuicyPixelsdep +aesondep +aeson-pretty

Dependencies added: JuicyPixels, aeson, aeson-pretty, base, base64-bytestring, bytestring, containers, haskeline, http-client, http-client-tls, intelli-monad, megaparsec, openai-servant-gen, persistent, persistent-sqlite, process, servant, servant-client, sixel, text, time, transformers, vector

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for intelli-monad++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2024 Junji Hashimoto++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,116 @@+# intelli-monad++intelli-monad provides high level APIs for prompt engineering using openai.++Featuring:+* Type level function calling with JSON-Schema+* Validation of return value+* Repl interface+* Persistent of prompt logs with SQLite+* Session management with repl++intelli-monad is based on openai-servant-gen.+openai-servant-gen is automatically generated from OpenAPI interface.++# Install++```bash+git clone git@github.com:junjihashimoto/intelli-monad.git+cd intelli-monad+export PATH=~/.local/bin:$PATH+cabal install intelli-monad+```++# Usage of repl++After install intelli-monad, set OPENAI_API_KEY, then run intelli-monad command.+The system commands begin with prefix ":". Anything else will be the user's prompt.++```bash+$ export OPENAI_API_KEY=xxx+$ export OPENAI_MODEL=xxx+$ intelli-monad+% :help+:quit+:clear+:show contents+:show usage+:show request+:show context+:show session+:list sessions+:copy session <from> <to>+:delete session <session name>+:switch session <session name>+:help+% hello+assistant: Hello! How can I assist you today?+```++# Usage of function calling with validation++Here is an example of function calling and validation.+In this example, validation is performed using the input of function calling.++Define the function calling as ValidateNumber, and define the context as Math.++JSONSchema type-class can output it as JSON Schema.+Defining HasFunctionObject class adds descriptin to each field. +This allows Openai's interface to understand the meaning of each field.+Tool type-class defines the input and output types of function calling, and defines the contents of the function.++CustomInstruction type-class defines the context with headers and footers.++runPromptWithValidation function calls LLM.+The results will be validated and a number will be returned.+++```haskell+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Main where++import Data.Aeson+import Data.Proxy+import GHC.Generics+import IntelliMonad.Persist+import IntelliMonad.Prompt+import IntelliMonad.Types+import OpenAI.Types++data ValidateNumber = ValidateNumber+  { number :: Double+  }+  deriving (Eq, Show, Generic, JSONSchema, FromJSON, ToJSON)++instance HasFunctionObject ValidateNumber where+  getFunctionName = "output_number"+  getFunctionDescription = "validate input number"+  getFieldDescription "number" = "A number that system outputs."++instance Tool ValidateNumber where+  data Output ValidateNumber = ValidateNumberOutput+    { code :: Int,+      stdout :: String,+      stderr :: String+    }+    deriving (Eq, Show, Generic, FromJSON, ToJSON)+  toolExec _ = return $ ValidateNumberOutput 0 "" ""++data Math = Math++instance CustomInstruction Math where+  customHeader = [(Content System (Message "Calcurate user input, then output just the number. Then call 'output_number' function.") "" defaultUTCTime)]+  customFooter = []++main :: IO ()+main = do+  v <- runPromptWithValidation @ValidateNumber @StatelessConf [] [CustomInstructionProxy (Proxy @Math)] "default" (fromModel "gpt-4") "2+3+3+sin(3)"+  print (v :: Maybe ValidateNumber)+```
+ app/auto-talk.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Main where++import Control.Monad.Trans.State (runStateT)+import Data.Proxy+import IntelliMonad.Persist+import IntelliMonad.Prompt+import IntelliMonad.Types++data Haruhi = Haruhi++instance CustomInstruction Haruhi where+  customHeader = [(Content System (Message "あなたは涼宮ハルヒとして会話してください。話す時は'haruhi: 'をつけて話してください。") "" defaultUTCTime)]+  customFooter = []++data Kyon = Kyon++instance CustomInstruction Kyon where+  customHeader = [(Content System (Message "あなたは涼宮ハルヒの同級生のキョンとして会話してください。話す時は'kyon: 'をつけて話してください。") "" defaultUTCTime)]+  customFooter = []++data Env = Env++instance CustomInstruction Env where+  customHeader = [(Content System (Message "あなたは涼宮ハルヒの世界の環境として状況を設定してください。話す時は'env: 'をつけて話してください。") "" defaultUTCTime)]+  customFooter = []++toUser :: Content -> Content+toUser c =+  if contentUser c == Assistant+    then c {contentUser = User}+    else c++main :: IO ()+main = do+  e <- initializePrompt @StatelessConf [] [CustomInstructionProxy (Proxy @Env)] "env" (fromModel "gpt-4")+  h <- initializePrompt @StatelessConf [] [CustomInstructionProxy (Proxy @Haruhi)] "haruhi" (fromModel "gpt-4")+  k <- initializePrompt @StatelessConf [] [CustomInstructionProxy (Proxy @Kyon)] "kyon" (fromModel "gpt-4")+  let init' = [Content User (Message "ある駄菓子屋の前での出来ことで話を作ってください。Let's start!") "default" defaultUTCTime]+  loop init' [] [] [] e h k+  where+    loop init' env haruhi kyon e h k = do+      (env, e) <- runStateT (callWithContents @StatelessConf (map toUser (init' <> haruhi <> kyon))) e+      print "--env--"+      showContents env+      (haruhi, h) <- runStateT (callWithContents @StatelessConf (map toUser (kyon <> env))) h+      print "--haruhi--"+      showContents haruhi+      (kyon, k) <- runStateT (callWithContents @StatelessConf (map toUser (env <> haruhi))) k+      print "--kyon--"+      showContents kyon+      loop [] env haruhi kyon e h k
+ app/calc.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Main where++import Data.Aeson+import Data.Proxy+import GHC.Generics+import IntelliMonad.Persist+import IntelliMonad.Prompt+import IntelliMonad.Types+import OpenAI.Types++data ValidateNumber = ValidateNumber+  { number :: Double+  }+  deriving (Eq, Show, Generic, JSONSchema, FromJSON, ToJSON)++instance HasFunctionObject ValidateNumber where+  getFunctionName = "output_number"+  getFunctionDescription = "validate input number"+  getFieldDescription "number" = "A number that system outputs."++instance Tool ValidateNumber where+  data Output ValidateNumber = ValidateNumberOutput+    { code :: Int,+      stdout :: String,+      stderr :: String+    }+    deriving (Eq, Show, Generic, FromJSON, ToJSON)+  toolExec _ = return $ ValidateNumberOutput 0 "" ""++data Math = Math++instance CustomInstruction Math where+  customHeader = [(Content System (Message "Calcurate user input, then output just the number. Then call 'output_number' function.") "" defaultUTCTime)]+  customFooter = []++main :: IO ()+main = do+  v <- runPromptWithValidation @ValidateNumber @StatelessConf [] [CustomInstructionProxy (Proxy @Math)] "default" (fromModel "gpt-4") "2+3+3+sin(3)"+  print (v :: Maybe ValidateNumber)
+ app/repl.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Main where++import qualified Data.Text as T+import Database.Persist.Sqlite (SqliteConf)+import IntelliMonad.CustomInstructions+import IntelliMonad.Repl+import IntelliMonad.Tools+import IntelliMonad.Types+import qualified OpenAI.Types as API+import System.Environment (lookupEnv)++main :: IO ()+main = do+  model <- do+    lookupEnv "OPENAI_MODEL" >>= \case+      Just model -> return $ T.pack model+      --      Nothing -> return "gpt-4-vision-preview"+      Nothing -> return "gpt-4"+  runRepl @SqliteConf+    defaultTools+    []+    "default"+    defaultRequest+      { API.createChatCompletionRequestModel = API.CreateChatCompletionRequestModel model+      }+    mempty
+ intelli-monad.cabal view
@@ -0,0 +1,146 @@+cabal-version:      3.0+name:               intelli-monad+version:            0.1.0.0+synopsis:           Type level prompt with openai.+description:        Type level prompt with openai. This allows us to define function calls and value validation using types.+license:            MIT++-- The file containing the license text.+license-file:       LICENSE++-- The package author(s).+author:             Junji Hashimoto++-- An email address to which users can send suggestions, bug reports, and patches.+maintainer:         junji.hashimoto@gmail.com++-- A copyright notice.+-- copyright:+category:           Development+build-type:         Simple++-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README.+extra-doc-files:    CHANGELOG.md+                    README.md++-- Extra source files to be distributed with the package, such as examples, or a tutorial module.+-- extra-source-files:++common warnings+    ghc-options: -Wall++library+    -- Import common warning flags.+    import:           warnings++    -- Modules exported by the library.+    exposed-modules:  IntelliMonad.Prompt+                    , IntelliMonad.Types+                    , IntelliMonad.Tools+                    , IntelliMonad.Tools.Bash+                    , IntelliMonad.Tools.TextToSpeech+                    , IntelliMonad.Tools.DallE3+                    , IntelliMonad.Tools.Utils+                    , IntelliMonad.Persist+                    , IntelliMonad.Repl+                    , IntelliMonad.CustomInstructions++    -- Modules included in this library but not exported.+    -- other-modules:++    -- LANGUAGE extensions used by modules in this package.+    -- other-extensions:++    -- Other library packages from which modules are imported.+    build-depends:    base ==4.*+                    , JuicyPixels >= 3.3.8 && < 3.4+                    , bytestring >= 0.11.5 && < 0.12+                    , containers >= 0.6.7 && < 0.7+                    , transformers >= 0.6.1 && < 0.7+                    , vector >= 0.13.1 && < 0.14+                    , aeson >= 2.1 && < 2.3+                    , text >= 2.0.2 && < 2.1+                    , time >= 1.12.2 && < 1.13+                    , aeson-pretty >= 0.8.10 && < 0.9+                    , process >= 1.6.17 && < 1.7+                    , base64-bytestring >= 1.2.1 && < 1.3+                    , haskeline >= 0.8.2 && < 0.9+                    , http-client >= 0.7.16 && < 0.8+                    , http-client-tls >= 0.3.6 && < 0.4+                    , megaparsec >= 9.5 && < 9.7+                    , openai-servant-gen >= 0.1.0 && < 0.2+                    , servant >= 0.20.1 && < 0.21+                    , servant-client >= 0.20 && < 0.21+                    , persistent >= 2.14.6 && < 2.15+                    , persistent-sqlite >= 2.13.3 && < 2.14+                    , sixel >= 0.1.2 && < 0.2+    -- Directories containing source files.+    hs-source-dirs:   src++    -- Base language which the package is written in.+    default-language: Haskell2010++executable intelli-monad+    import:           warnings+    main-is:          repl.hs+    build-depends:+        base == 4.*,+        intelli-monad,+        openai-servant-gen,+        text,+        process,+        persistent-sqlite+    hs-source-dirs:   app+    default-language: Haskell2010++executable calc+    import:           warnings+    main-is:          calc.hs+    build-depends:+        base == 4.*,+        intelli-monad,+        openai-servant-gen,+        text,+        aeson+    hs-source-dirs:   app+    default-language: Haskell2010++executable auto-talk+    import:           warnings+    main-is:          auto-talk.hs+    build-depends:+        base == 4.*,+        intelli-monad,+        openai-servant-gen,+        text,+        aeson,+        transformers+    hs-source-dirs:   app+    default-language: Haskell2010+    +test-suite intelli-monad-test+    -- Import common warning flags.+    import:           warnings++    -- Base language which the package is written in.+    default-language: Haskell2010++    -- Modules included in this executable, other than Main.+    -- other-modules:++    -- LANGUAGE extensions used by modules in this package.+    -- other-extensions:++    -- The interface type and version of the test suite.+    type:             exitcode-stdio-1.0++    -- Directories containing source files.+    hs-source-dirs:   test++    -- The entrypoint to the test suite.+    main-is:          Main.hs++    -- Test dependencies.+    build-depends:+        base ==4.*,+        intelli-monad
+ src/IntelliMonad/CustomInstructions.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module IntelliMonad.CustomInstructions where++import qualified Data.Aeson as A+import Data.Proxy+import GHC.Generics+import IntelliMonad.Types+import qualified OpenAI.Types as API++defaultCustomInstructions :: [CustomInstructionProxy]+defaultCustomInstructions = []++data ValidateNumber = ValidateNumber+  { number :: Double+  }+  deriving (Eq, Show, Generic, JSONSchema, A.FromJSON, A.ToJSON)++instance HasFunctionObject ValidateNumber where+  getFunctionName = "output_number"+  getFunctionDescription = "validate input number"+  getFieldDescription "number" = "A number that system outputs."++instance Tool ValidateNumber where+  data Output ValidateNumber = ValidateNumberOutput+    { code :: Int,+      stdout :: String,+      stderr :: String+    }+    deriving (Eq, Show, Generic, A.FromJSON, A.ToJSON)+  toolExec _ = do+    return $ ValidateNumberOutput 0 "" ""++data Math = Math++instance CustomInstruction Math where+  customHeader = [(Content System (Message "Calcurate user input, then output just the number. Then call 'output_number' function.") "" defaultUTCTime)]+  customFooter = []++headers :: [CustomInstructionProxy] -> Contents+headers [] = []+headers (tool : tools') =+  case tool of+    (CustomInstructionProxy (_ :: Proxy a)) -> customHeader @a <> headers tools'++footers :: [CustomInstructionProxy] -> Contents+footers [] = []+footers (tool : tools') =+  case tool of+    (CustomInstructionProxy (_ :: Proxy a)) -> customFooter @a <> footers tools'
+ src/IntelliMonad/Persist.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module IntelliMonad.Persist where++import Control.Monad.IO.Class+import Data.List (maximumBy)+import qualified Data.Set as S+import Data.Text (Text)+import Database.Persist+import Database.Persist.Sqlite+import IntelliMonad.Types++data StatelessConf = StatelessConf++class PersistentBackend p where+  type Conn p+  config :: p+  setup :: (MonadIO m, MonadFail m) => p -> m (Maybe (Conn p))+  initialize :: (MonadIO m, MonadFail m) => Conn p -> Context -> m ()+  load :: (MonadIO m, MonadFail m) => Conn p -> SessionName -> m (Maybe Context)+  loadByKey :: (MonadIO m, MonadFail m) => Conn p -> (Key Context) -> m (Maybe Context)+  save :: (MonadIO m, MonadFail m) => Conn p -> Context -> m (Maybe (Key Context))+  saveContents :: (MonadIO m, MonadFail m) => Conn p -> [Content] -> m ()+  listSessions :: (MonadIO m, MonadFail m) => Conn p -> m [Text]+  deleteSession :: (MonadIO m, MonadFail m) => Conn p -> SessionName -> m ()++instance PersistentBackend SqliteConf where+  type Conn SqliteConf = ConnectionPool+  config =+    SqliteConf+      { sqlDatabase = "intelli-monad.sqlite3",+        sqlPoolSize = 5+      }+  setup p = do+    conn <- liftIO $ createPoolConfig p+    liftIO $ runPool p (runMigration migrateAll) conn+    return $ Just conn+  initialize conn context = do+    _ <- liftIO $ runPool (config @SqliteConf) (insert context) conn+    return ()+  load conn sessionName = do+    (a :: [Entity Context]) <- liftIO $ runPool (config @SqliteConf) (selectList [ContextSessionName ==. sessionName] []) conn+    if length a == 0+      then return Nothing+      else return $ Just $ maximumBy (\a0 a1 -> compare (contextCreated a1) (contextCreated a0)) $ map (\(Entity _ v) -> v) a++  loadByKey conn key = do+    (a :: [Entity Context]) <- liftIO $ runPool (config @SqliteConf) (selectList [ContextId ==. key] []) conn+    if length a == 0+      then return Nothing+      else return $ Just $ maximumBy (\a0 a1 -> compare (contextCreated a1) (contextCreated a0)) $ map (\(Entity _ v) -> v) a++  save conn context = do+    liftIO $ runPool (config @SqliteConf) (Just <$> insert context) conn++  saveContents conn contents = do+    liftIO $ runPool (config @SqliteConf) (putMany contents) conn++  listSessions conn = do+    (a :: [Entity Context]) <- liftIO $ runPool (config @SqliteConf) (selectList [] []) conn+    return $ S.toList $ S.fromList $ map (\(Entity _ v) -> contextSessionName v) a++  deleteSession conn sessionName = do+    liftIO $ runPool (config @SqliteConf) (deleteWhere [ContextSessionName ==. sessionName]) conn++instance PersistentBackend StatelessConf where+  type Conn StatelessConf = ()+  config = StatelessConf+  setup _ = return $ Just ()+  initialize _ _ = return ()+  load _ _ = return Nothing+  loadByKey _ _ = return Nothing+  save _ _ = return Nothing+  saveContents _ _ = return ()+  listSessions _ = return []+  deleteSession _ _ = return ()++withDB :: forall p m a. (MonadIO m, MonadFail m, PersistentBackend p) => (Conn p -> m a) -> m a+withDB func =+  setup (config @p) >>= \case+    Nothing -> fail "Can not open a database."+    Just (conn :: Conn p) -> func conn
+ src/IntelliMonad/Prompt.hs view
@@ -0,0 +1,370 @@+{-# 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 = context <$> get++setContext :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => Context -> Prompt m ()+setContext context = do+  env <- get+  put $ env {context = context}+  _ <- withDB @p $ \conn -> save @p (conn :: Conn p) context+  return ()++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+  let nextContents = prev.contextBody <> contents+      next =+        prev+          { contextBody = nextContents,+            contextRequest = toRequest prev.contextRequest (prev.contextHeader <> nextContents <> prev.contextFooter)+          }+  setContext @p next++  withDB @p $ \conn -> saveContents @p conn contents+  return ()++pushToolReturn :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => Contents -> Prompt m ()+pushToolReturn contents = do+  prev <- getContext+  let toolMap = M.fromList (map (\v@(Content _ (ToolReturn id' _ _) _ _) -> (id', v)) contents)+      nextContents =+        concat $+          map+            ( \v -> case v of+                Content _ (Message _) _ _ -> [v]+                Content _ (Image _ _) _ _ -> [v]+                Content _ (ToolCall id' _ _) _ _ ->+                  case M.lookup id' toolMap of+                    Just v' -> [v, v']+                    Nothing -> [v]+                Content _ (ToolReturn _ _ _) _ _ -> [v]+            )+            prev.contextBody+      next =+        prev+          { contextBody = nextContents,+            contextRequest = toRequest prev.contextRequest (prev.contextHeader <> nextContents <> prev.contextFooter)+          }+  setContext @p next++  withDB @p $ \conn -> saveContents @p conn contents+  return ()++call :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => Prompt m Contents+call = loop []+  where+    loop ret = do+      prev <- getContext+      ((contents, finishReason), res) <- liftIO $ runRequest prev.contextSessionName prev.contextRequest (prev.contextHeader <> prev.contextBody <> prev.contextFooter)+      let current_total_tokens = fromMaybe 0 $ API.completionUsageTotalUnderscoretokens <$> API.createChatCompletionResponseUsage res+          next =+            prev+              { contextResponse = Just res,+                contextTotalTokens = current_total_tokens+              }+      setContext @p next+      push @p contents++      let ret' = ret <> contents++      case finishReason of+        Stop -> return ret'+        ToolCalls -> callTool next contents ret'+        FunctionCall -> callTool next contents ret'+        Length -> loop ret'+        _ -> return ret'++    callTool next contents ret = do+      showContents contents+      env <- get+      retTool <- tryToolExec env.tools next.contextSessionName contents+      showContents retTool+      pushToolReturn @p retTool+      v <- call @p+      return $ ret <> retTool <> v++callWithText :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => Text -> Prompt m Contents+callWithText input = do+  time <- liftIO getCurrentTime+  context <- getContext+  let contents = [Content User (Message input) context.contextSessionName time]+  push @p contents+  call @p++callWithContents :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => Contents -> Prompt m Contents+callWithContents input = do+  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)+  ) => 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)+  ) =>+  [ToolProxy] ->+  [CustomInstructionProxy] ->+  Text ->+  API.CreateChatCompletionRequest ->+  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)++initializePrompt :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => [ToolProxy] -> [CustomInstructionProxy] -> Text -> API.CreateChatCompletionRequest -> m PromptEnv+initializePrompt tools customs sessionName req = do+  let settings = addTools tools (req {API.createChatCompletionRequestTools = Nothing})+  withDB @p $ \conn -> do+    load @p conn sessionName >>= \case+      Just v ->+        return $+          PromptEnv+            { context = v,+              tools = tools,+              customInstructions = customs+            }+      Nothing -> do+        time <- liftIO getCurrentTime+        let init' =+              PromptEnv+                { context =+                    Context+                      { contextRequest = settings,+                        contextResponse = Nothing,+                        contextHeader = headers customs,+                        contextBody = [],+                        contextFooter = footers customs,+                        contextTotalTokens = 0,+                        contextSessionName = sessionName,+                        contextCreated = time+                      },+                  tools = tools,+                  customInstructions = customs+                }+        initialize @p conn (init'.context)+        return init'++runPrompt :: forall p m a. (MonadIO m, MonadFail m, PersistentBackend p) => [ToolProxy] -> [CustomInstructionProxy] -> Text -> API.CreateChatCompletionRequest -> Prompt m a -> m a+runPrompt tools customs sessionName req func = do+  context <- initializePrompt @p tools customs sessionName req+  fst <$> runStateT func context++instance ChatCompletion Contents where+  toRequest orgRequest contents =+    let messages = flip map contents $ \case+          Content user (Message message) _ _ ->+            API.ChatCompletionRequestMessage+              { API.chatCompletionRequestMessageContent = Just $ API.ChatCompletionRequestMessageContentText message,+                API.chatCompletionRequestMessageRole = userToText user,+                API.chatCompletionRequestMessageName = Nothing,+                API.chatCompletionRequestMessageToolUnderscorecalls = Nothing,+                API.chatCompletionRequestMessageFunctionUnderscorecall = Nothing,+                API.chatCompletionRequestMessageToolUnderscorecallUnderscoreid = Nothing+              }+          Content user (Image type' img) _ _ ->+            API.ChatCompletionRequestMessage+              { API.chatCompletionRequestMessageContent =+                  Just $+                    API.ChatCompletionRequestMessageContentParts+                      [ API.ChatCompletionRequestMessageContentPart+                          { API.chatCompletionRequestMessageContentPartType = "image_url",+                            API.chatCompletionRequestMessageContentPartText = Nothing,+                            API.chatCompletionRequestMessageContentPartImageUnderscoreurl =+                              Just $+                                API.ChatCompletionRequestMessageContentPartImageImageUrl+                                  { API.chatCompletionRequestMessageContentPartImageImageUrlUrl =+                                      "data:image/" <> type' <> ";base64," <> img,+                                    API.chatCompletionRequestMessageContentPartImageImageUrlDetail = Nothing+                                  }+                          }+                      ],+                API.chatCompletionRequestMessageRole = userToText user,+                API.chatCompletionRequestMessageName = Nothing,+                API.chatCompletionRequestMessageToolUnderscorecalls = Nothing,+                API.chatCompletionRequestMessageFunctionUnderscorecall = Nothing,+                API.chatCompletionRequestMessageToolUnderscorecallUnderscoreid = Nothing+              }+          Content user (ToolCall id' name' args') _ _ ->+            API.ChatCompletionRequestMessage+              { API.chatCompletionRequestMessageContent = Nothing,+                API.chatCompletionRequestMessageRole = userToText user,+                API.chatCompletionRequestMessageName = Nothing,+                API.chatCompletionRequestMessageToolUnderscorecalls =+                  Just+                    [ API.ChatCompletionMessageToolCall+                        { API.chatCompletionMessageToolCallId = id',+                          API.chatCompletionMessageToolCallType = "function",+                          API.chatCompletionMessageToolCallFunction =+                            API.ChatCompletionMessageToolCallFunction+                              { API.chatCompletionMessageToolCallFunctionName = name',+                                API.chatCompletionMessageToolCallFunctionArguments = args'+                              }+                        }+                    ],+                API.chatCompletionRequestMessageFunctionUnderscorecall = Nothing,+                API.chatCompletionRequestMessageToolUnderscorecallUnderscoreid = Just id'+              }+          Content user (ToolReturn id' name' ret') _ _ ->+            API.ChatCompletionRequestMessage+              { API.chatCompletionRequestMessageContent = Just $ API.ChatCompletionRequestMessageContentText ret',+                API.chatCompletionRequestMessageRole = userToText user,+                API.chatCompletionRequestMessageName = Just name',+                API.chatCompletionRequestMessageToolUnderscorecalls = Nothing,+                API.chatCompletionRequestMessageFunctionUnderscorecall = Nothing,+                API.chatCompletionRequestMessageToolUnderscorecallUnderscoreid = Just id'+              }+     in orgRequest {API.createChatCompletionRequestMessages = messages}+  fromResponse sessionName response =+    let res = head (API.createChatCompletionResponseChoices response)+        message = API.createChatCompletionResponseChoicesInnerMessage res+        role = textToUser $ API.chatCompletionResponseMessageRole message+        content = API.chatCompletionResponseMessageContent message+        finishReason = textToFinishReason $ API.createChatCompletionResponseChoicesInnerFinishUnderscorereason res+        v = case API.chatCompletionResponseMessageToolUnderscorecalls message of+          Just toolcalls -> map (\(API.ChatCompletionMessageToolCall id' _ (API.ChatCompletionMessageToolCallFunction name' args')) -> Content role (ToolCall id' name' args') sessionName defaultUTCTime) toolcalls+          Nothing -> [Content role (Message (fromMaybe "" content)) sessionName defaultUTCTime]+     in (v, finishReason)++runRequest :: (ChatCompletion a) => Text -> API.CreateChatCompletionRequest -> a -> IO ((a, FinishReason), API.CreateChatCompletionResponse)+runRequest sessionName defaultReq request = do+  api_key <- (API.clientAuth . T.pack) <$> getEnv "OPENAI_API_KEY"+  url <- do+    lookupEnv "OPENAI_ENDPOINT" >>= \case+      Just url -> parseBaseUrl url+      Nothing -> parseBaseUrl "https://api.openai.com/v1/"+  manager <-+    newManager+      ( tlsManagerSettings+          { managerResponseTimeout = responseTimeoutMicro (120 * 1000 * 1000)+          }+      )+  let API.OpenAIBackend {..} = API.createOpenAIClient+      req = (toRequest defaultReq request)++  lookupEnv "OPENAI_DEBUG" >>= \case+    Just "1" -> do+      liftIO $ do+        BS.putStr $ BS.toStrict $ encodePretty req+        T.putStrLn ""+    _ -> return ()+  res <- API.callOpenAI (mkClientEnv manager url) $ createChatCompletion api_key req+  return (fromResponse sessionName res, res)++showContents :: (MonadIO m) => Contents -> m ()+showContents res = do+  forM_ res $ \(Content user message _ _) ->+    liftIO $+      T.putStrLn $+        userToText user+          <> ": "+          <> case message of+            Message t -> t+            Image _ _ -> "Image: ..."+            c@(ToolCall _ _ _) -> T.pack $ show c+            c@(ToolReturn _ _ _) -> T.pack $ show c++fromModel :: Text -> API.CreateChatCompletionRequest+fromModel model =+  defaultRequest+    { API.createChatCompletionRequestModel = API.CreateChatCompletionRequestModel model+    }++clear :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => Prompt m ()+clear = do+  prev <- getContext+  setContext @p $ prev {contextBody = []}++callWithImage :: forall p m. (MonadIO m, MonadFail m, PersistentBackend p) => Text -> Prompt m Contents+callWithImage imagePath = do+  let tryReadFile = T.decodeUtf8Lenient . Base64.encode <$> BS.readFile (T.unpack imagePath)+      imageType =+        if T.isSuffixOf ".png" imagePath+          then "png"+          else+            if T.isSuffixOf ".jpg" imagePath || T.isSuffixOf ".jpeg" imagePath+              then "jpeg"+              else "jpeg"+  file <- liftIO $ tryReadFile+  time <- liftIO getCurrentTime+  context <- getContext+  let contents' = [Content User (Image imageType file) context.contextSessionName time]+  callWithContents @p contents'
+ src/IntelliMonad/Repl.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# 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.Repl where++import Control.Monad (forM_)+import Control.Monad.IO.Class+import Control.Monad.Trans.Class (MonadTrans, lift)+import Control.Monad.Trans.State (get, put)+import Data.Aeson.Encode.Pretty (encodePretty)+import qualified Data.ByteString as BS+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Void+import IntelliMonad.Persist+import IntelliMonad.Prompt+import IntelliMonad.Types+import qualified OpenAI.Types as API+import System.Console.Haskeline+import Text.Megaparsec+import Text.Megaparsec.Char+import Text.Megaparsec.Char.Lexer as L++type Parser = Parsec Void Text++data ReplCommand+  = Quit+  | Clear+  | ShowContents+  | ShowUsage+  | ShowRequest+  | ShowContext+  | ShowSession+  | ListSessions+  | CopySession (Text, Text)+  | DeleteSession Text+  | SwitchSession Text+  | ReadImage Text+  | UserInput Text+  | Help+  deriving (Eq, Show)++parseRepl :: Parser ReplCommand+parseRepl =+  (try (lexm (string ":quit")) >> pure Quit)+    <|> (try (lexm (string ":clear")) >> pure Clear)+    <|> (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 ":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)+    <|> ( try+            ( lexm (string ":copy") >> lexm (string "session") >> do+                from <- T.pack <$> lexm sessionName+                to <- T.pack <$> lexm sessionName+                return (from, to)+            )+            >>= pure . CopySession+        )+    <|> (try (lexm (string ":delete") >> lexm (string "session") >> lexm sessionName) >>= pure . DeleteSession . T.pack)+    <|> (try (lexm (string ":switch") >> lexm (string "session") >> lexm sessionName) >>= pure . SwitchSession . T.pack)+    <|> (try (lexm (string ":help")) >> pure Help)+  where+    sc = L.space space1 empty empty+    lexm = lexeme sc+    sessionName = many alphaNumChar+    imagePath = many (alphaNumChar <|> char '.' <|> char '/' <|> char '-')++getTextInputLine :: (MonadTrans t) => t (InputT IO) (Maybe T.Text)+getTextInputLine = fmap (fmap T.pack) (lift $ getInputLine "% ")++getUserCommand :: forall p t. (PersistentBackend p, MonadTrans t) => t (InputT IO) (Either (ParseErrorBundle Text Void) ReplCommand)+getUserCommand = do+  minput <- getTextInputLine+  case minput of+    Nothing -> return $ Right Quit+    Just input ->+      if T.isPrefixOf ":" input+        then case runParser parseRepl "stdin" input of+          Right v -> return $ Right v+          Left err -> return $ Left err+        else return $ Right (UserInput input)++runRepl' :: forall p. (PersistentBackend p) => Prompt (InputT IO) ()+runRepl' = do+  getUserCommand @p >>= \case+    Left err -> do+      liftIO $ print err+      runRepl' @p+    Right Quit -> return ()+    Right Clear -> do+      clear @p+      runRepl' @p+    Right ShowContents -> do+      context <- getContext+      showContents context.contextBody+      runRepl' @p+    Right ShowUsage -> do+      context <- getContext+      liftIO $ do+        print context.contextTotalTokens+      runRepl' @p+    Right ShowRequest -> do+      prev <- getContext+      let req = toRequest prev.contextRequest (prev.contextHeader <> prev.contextBody <> prev.contextFooter)+      liftIO $ do+        BS.putStr $ BS.toStrict $ encodePretty req+        T.putStrLn ""+      runRepl' @p+    Right ShowContext -> do+      prev <- getContext+      liftIO $ do+        putStrLn $ show prev+      runRepl' @p+    Right ShowSession -> do+      prev <- getContext+      liftIO $ do+        T.putStrLn $ prev.contextSessionName+      runRepl' @p+    Right ListSessions -> do+      liftIO $ do+        list <- withDB @p $ \conn -> listSessions @p conn+        forM_ list $ \sessionName' -> T.putStrLn sessionName'+      runRepl' @p+    Right (CopySession (from', to')) -> do+      liftIO $ do+        withDB @p $ \conn -> do+          mv <- load @p conn from'+          case mv of+            Just v -> do+              _ <- save @p conn (v {contextSessionName = to'})+              return ()+            Nothing -> T.putStrLn $ "Failed to load " <> from'+      runRepl' @p+    Right (DeleteSession session) -> do+      withDB @p $ \conn -> deleteSession @p conn session+      runRepl' @p+    Right (SwitchSession session) -> do+      mv <- withDB @p $ \conn -> load @p conn session+      case mv of+        Just v -> do+          (env :: PromptEnv) <- get+          put $ env {context = v}+        Nothing -> liftIO $ T.putStrLn $ "Failed to load " <> session+      runRepl' @p+    Right (ReadImage imagePath) -> do+      callWithImage @p imagePath >>= showContents+      runRepl' @p+    Right Help -> do+      liftIO $ do+        putStrLn ":quit"+        putStrLn ":clear"+        putStrLn ":show contents"+        putStrLn ":show usage"+        putStrLn ":show request"+        putStrLn ":show context"+        putStrLn ":show session"+        putStrLn ":list sessions"+        putStrLn ":copy session <from> <to>"+        putStrLn ":delete session <session name>"+        putStrLn ":switch session <session name>"+        putStrLn ":help"+      runRepl' @p+    Right (UserInput input) -> do+      callWithText @p input >>= showContents+      runRepl' @p++runRepl :: forall p. (PersistentBackend p) => [ToolProxy] -> [CustomInstructionProxy] -> Text -> API.CreateChatCompletionRequest -> Contents -> IO ()+runRepl tools customs sessionName defaultReq contents = do+  runInputT+    ( Settings+        { complete = completeFilename,+          historyFile = Just "intelli-monad.history",+          autoAddHistory = True+        }+    )+    (runPrompt @p tools customs sessionName defaultReq (push @p contents >> runRepl' @p))
+ src/IntelliMonad/Tools.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module IntelliMonad.Tools+  ( module IntelliMonad.Tools.Utils,+    module IntelliMonad.Tools.Bash,+    module IntelliMonad.Tools.TextToSpeech,+    module IntelliMonad.Tools.DallE3,+    defaultTools,+  )+where++import Data.Proxy+import IntelliMonad.Tools.Bash+import IntelliMonad.Tools.DallE3+import IntelliMonad.Tools.TextToSpeech+import IntelliMonad.Tools.Utils+import IntelliMonad.Types++defaultTools :: [ToolProxy]+defaultTools =+  [ ToolProxy (Proxy :: Proxy Bash),+    ToolProxy (Proxy :: Proxy TextToSpeech),+    ToolProxy (Proxy :: Proxy DallE3)+  ]
+ src/IntelliMonad/Tools/Bash.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module IntelliMonad.Tools.Bash where++import qualified Data.Aeson as A+import GHC.Generics+import GHC.IO.Exception+import IntelliMonad.Types+import qualified OpenAI.Types as API+import System.Process++data Bash = Bash+  { script :: String+  }+  deriving (Eq, Show, Generic, JSONSchema, A.FromJSON, A.ToJSON)++instance HasFunctionObject Bash where+  getFunctionName = "call_bash_script"+  getFunctionDescription = "Call a bash script in a local environment"+  getFieldDescription "script" = "A script executing in a local environment"++instance Tool Bash where+  data Output Bash = BashOutput+    { code :: Int,+      stdout :: String,+      stderr :: String+    }+    deriving (Eq, Show, Generic, A.FromJSON, A.ToJSON)++  toolExec args = do+    (code, stdout, stderr) <- readCreateProcessWithExitCode (shell args.script) ""+    let code' = case code of+          ExitSuccess -> 0+          ExitFailure v -> v+    return $ BashOutput code' stdout stderr
+ src/IntelliMonad/Tools/DallE3.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module IntelliMonad.Tools.DallE3 where++import Codec.Picture+import Control.Monad.IO.Class+import qualified Data.Aeson as A+import qualified Data.ByteString.Lazy as LBS+import Data.Maybe (fromMaybe)+import qualified Data.OSC1337 as OSC+import qualified Data.Sixel as Sixel+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics+import IntelliMonad.Types+import Network.HTTP.Client (httpLbs, newManager, parseUrlThrow, responseBody)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import qualified OpenAI.API as API+import qualified OpenAI.Types as API+import Servant.Client+import System.Environment (getEnv, lookupEnv)++putImage :: FilePath -> IO (Either String ())+putImage image' = do+  termProgram <- lookupEnv "TERM_PROGRAM"+  imageBin <- readImage image'+  case imageBin of+    Left err -> return $ Left $ "Image file " ++ image' ++ " can not be read. : " ++ show err+    Right imageBin' -> do+      let image = convertRGB8 imageBin'+      case termProgram of+        Just "iTerm.app" -> do+          OSC.putOSC image+          putStrLn ""+        Just "vscode" -> do+          Sixel.putSixel image+          putStrLn ""+        _ -> do+          Sixel.putSixel image+          putStrLn ""+      return $ Right ()++data DallE3 = DallE3+  { prompt :: T.Text,+    size :: T.Text+  }+  deriving (Eq, Show, Generic, JSONSchema, A.FromJSON, A.ToJSON)++instance HasFunctionObject DallE3 where+  getFunctionName = "image_generation"+  getFunctionDescription = "Creating images from scratch based on a text prompt"+  getFieldDescription "prompt" = "A text description of the desired image. The maximum length is 4000 characters."+  getFieldDescription "size" = "The size of the generated images. Must be one of 1024x1024, 1792x1024, or 1024x1792 for dall-e-3 models."++instance Tool DallE3 where+  data Output DallE3 = DallE3Output+    { code :: Int,+      stdout :: String,+      stderr :: String,+      url :: Text+    }+    deriving (Eq, Show, Generic, A.FromJSON, A.ToJSON)+  toolExec args = do+    api_key <- (API.clientAuth . T.pack) <$> getEnv "OPENAI_API_KEY"+    url <- parseBaseUrl "https://api.openai.com/v1/"+    manager <- newManager tlsManagerSettings+    let API.OpenAIBackend {..} = API.createOpenAIClient+    let request =+          API.CreateImageRequest+            { createImageRequestPrompt = args.prompt,+              createImageRequestModel = Just $ API.CreateImageRequestModel "dall-e-3",+              createImageRequestN = Nothing,+              createImageRequestQuality = Nothing,+              createImageRequestResponseUnderscoreformat = Just "url",+              createImageRequestSize = Just args.size,+              createImageRequestStyle = Nothing,+              createImageRequestUser = Nothing+            }+    res <- API.callOpenAI (mkClientEnv manager url) $ createImage api_key request+    let url' = case res of+          (API.ImagesResponse _ (img : _)) -> fromMaybe "" (API.imageUrl img)+          _ -> ""+    let downloadImage = do+          request' <- parseUrlThrow $ T.unpack url'+          manager' <- newManager tlsManagerSettings+          response <- httpLbs request' manager'+          let imageBytes = Network.HTTP.Client.responseBody response+          LBS.writeFile "image.png" imageBytes+    downloadImage+    err <- do+      liftIO $+        putImage "image.png" >>= \case+          Left err -> return err+          Right _ -> return ""+    return $ DallE3Output 0 "" err url'
+ src/IntelliMonad/Tools/TextToSpeech.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module IntelliMonad.Tools.TextToSpeech where++import qualified Data.Aeson as A+import qualified Data.ByteString as BS+import qualified Data.Text as T+import GHC.Generics+import GHC.IO.Exception+import IntelliMonad.Types+import Network.HTTP.Client (newManager)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import qualified OpenAI.API as API+import qualified OpenAI.Types as API+import Servant.Client+import System.Environment (getEnv)+import System.Process++data TextToSpeech = TextToSpeech+  { script :: T.Text+  }+  deriving (Eq, Show, Generic, JSONSchema, A.FromJSON, A.ToJSON)++instance HasFunctionObject TextToSpeech where+  getFunctionName = "text_to_speech"+  getFunctionDescription = "Speak text"+  getFieldDescription "script" = "A script for speech"++instance Tool TextToSpeech where+  data Output TextToSpeech = TextToSpeechOutput+    { code :: Int,+      stdout :: String,+      stderr :: String+    }+    deriving (Eq, Show, Generic, A.FromJSON, A.ToJSON)+  toolExec args = do+    api_key <- (API.clientAuth . T.pack) <$> getEnv "OPENAI_API_KEY"+    url <- parseBaseUrl "https://api.openai.com/v1/"+    manager <- newManager tlsManagerSettings+    let API.OpenAIBackend {..} = API.createOpenAIClient+    let request =+          API.CreateSpeechRequest+            { API.createSpeechRequestModel = API.CreateSpeechRequestModel "tts-1",+              API.createSpeechRequestInput = args.script,+              API.createSpeechRequestVoice = "alloy",+              API.createSpeechRequestResponseUnderscoreformat = Just "mp3",+              API.createSpeechRequestSpeed = Nothing+            }+    res <- API.callOpenAI (mkClientEnv manager url) $ createSpeech api_key request+    BS.writeFile "out.mp3" res+    (code, stdout, stderr) <- readCreateProcessWithExitCode (shell $ "afplay " <> "out.mp3") ""+    let code' = case code of+          ExitSuccess -> 0+          ExitFailure v -> v+    return $ TextToSpeechOutput code' stdout stderr
+ src/IntelliMonad/Tools/Utils.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module IntelliMonad.Tools.Utils where++import Control.Monad (forM)+import Control.Monad.IO.Class+import Data.Aeson (encode)+import qualified Data.Aeson as A+import qualified Data.ByteString as BS+import Data.Maybe (catMaybes)+import Data.Proxy+import Data.Text (Text)+import qualified Data.Text.Encoding as T+import Data.Time+import IntelliMonad.Types+import qualified OpenAI.Types as API++addTools :: [ToolProxy] -> API.CreateChatCompletionRequest -> API.CreateChatCompletionRequest+addTools [] v = v+addTools (tool : tools') v =+  case tool of+    (ToolProxy (_ :: Proxy a)) -> addTools tools' (toolAdd @a v)++toolExec' ::+  forall t m.+  (MonadIO m, MonadFail m, Tool t, A.FromJSON t, A.ToJSON (Output t)) =>+  Text ->+  Text ->+  Text ->+  Text ->+  Prompt m (Maybe Content)+toolExec' sessionName id' name' args' = do+  if name' == toolFunctionName @t+    then case (A.eitherDecode (BS.fromStrict (T.encodeUtf8 args')) :: Either String t) of+      Left _ -> return Nothing+      Right input -> do+        output <- liftIO $ toolExec input+        time <- liftIO getCurrentTime+        return $ Just $ (Content Tool (ToolReturn id' name' (T.decodeUtf8Lenient (BS.toStrict (encode output)))) sessionName time)+    else return Nothing++(<||>) ::+  forall m.+  (MonadIO m, MonadFail m) =>+  (Text -> Text -> Text -> Text -> Prompt m (Maybe Content)) ->+  (Text -> Text -> Text -> Text -> Prompt m (Maybe Content)) ->+  Text ->+  Text ->+  Text ->+  Text ->+  Prompt m (Maybe Content)+(<||>) tool0 tool1 sessionName id' name' args' = do+  a <- tool0 sessionName id' name' args'+  case a of+    Just v -> return (Just v)+    Nothing -> tool1 sessionName id' name' args'++mergeToolCall :: (MonadIO m, MonadFail m) => [ToolProxy] -> Text -> Text -> Text -> Text -> Prompt m (Maybe Content)+mergeToolCall [] _ _ _ _ = return Nothing+mergeToolCall (tool : tools') sessionName id' name' args' = do+  case tool of+    (ToolProxy (_ :: Proxy a)) -> (toolExec' @a <||> mergeToolCall tools') sessionName id' name' args'++hasToolCall :: Contents -> Bool+hasToolCall cs =+  let loop [] = False+      loop ((Content _ (ToolCall _ _ _) _ _) : _) = True+      loop (_ : cs') = loop cs'+   in loop cs++filterToolCall :: Contents -> Contents+filterToolCall cs =+  let loop [] = []+      loop (m@(Content _ (ToolCall _ _ _) _ _) : cs') = m : loop cs'+      loop (_ : cs') = loop cs'+   in loop cs++tryToolExec :: (MonadIO m, MonadFail m) => [ToolProxy] -> Text -> Contents -> Prompt m Contents+tryToolExec tools sessionName contents = do+  cs <- forM (filterToolCall contents) $ \(Content _ (ToolCall id' name' args') _ _) -> do+    mergeToolCall tools sessionName id' name' args'+  return $ catMaybes cs++findToolCall :: ToolProxy -> Contents -> Maybe Content+findToolCall _ [] = Nothing+findToolCall t@(ToolProxy (Proxy :: Proxy a)) (c : cs) =+  case c of+    Content _ (Message _) _ _ -> findToolCall t cs+    Content _ (Image _ _) _ _ -> findToolCall t cs+    Content _ (ToolCall _ name' _) _ _ ->+      if name' == toolFunctionName @a+        then Just c+        else findToolCall t cs+    Content _ (ToolReturn _ _ _) _ _ -> findToolCall t cs
+ src/IntelliMonad/Types.hs view
@@ -0,0 +1,406 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module IntelliMonad.Types where++import qualified Codec.Picture as P+import Control.Monad.Trans.State (StateT)+import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode)+import qualified Data.Aeson as A+import qualified Data.Aeson.Key as A+import qualified Data.Aeson.KeyMap as A+import Data.ByteString (ByteString, fromStrict, toStrict)+import Data.Coerce+import Data.Kind (Type)+import qualified Data.Map as M+import Data.Proxy+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time+import qualified Data.Vector as V+import Database.Persist+import Database.Persist.Sqlite+import Database.Persist.TH+import GHC.Generics+import qualified OpenAI.Types as API++data User = User | System | Assistant | Tool deriving (Eq, Show, Ord, Generic)++instance ToJSON User++instance FromJSON User++userToText :: User -> Text+userToText = \case+  User -> "user"+  System -> "system"+  Assistant -> "assistant"+  Tool -> "tool"++textToUser :: Text -> User+textToUser = \case+  "user" -> User+  "system" -> System+  "assistant" -> Assistant+  "tool" -> Tool+  v -> error $ T.unpack $ "Undefined role:" <> v++instance Show (P.Image P.PixelRGB8) where+  show _ = "Image: ..."++data Message+  = Message+      {unText :: Text}+  | Image+      { imageType :: Text,+        imageData :: Text+      }+  | ToolCall+      { toolId :: Text,+        toolName :: Text,+        toolArguments :: Text+      }+  | ToolReturn+      { toolId :: Text,+        toolName :: Text,+        toolContent :: Text+      }+  deriving (Eq, Show, Ord, Generic)++data FinishReason+  = Stop+  | Length+  | ToolCalls+  | FunctionCall+  | ContentFilter+  | Null+  deriving (Eq, Show)++finishReasonToText :: FinishReason -> Text+finishReasonToText = \case+  Stop -> "stop"+  Length -> "length"+  ToolCalls -> "tool_calls"+  FunctionCall -> "function_call"+  ContentFilter -> "content_fileter"+  Null -> "null"++textToFinishReason :: Text -> FinishReason+textToFinishReason = \case+  "stop" -> Stop+  "length" -> Length+  "tool_calls" -> ToolCalls+  "function_call" -> FunctionCall+  "content_filter" -> ContentFilter+  "null" -> Null+  _ -> Null++instance ToJSON Message++instance FromJSON Message++newtype Model = Model Text deriving (Eq, Show)++class ChatCompletion a where+  toRequest :: API.CreateChatCompletionRequest -> a -> API.CreateChatCompletionRequest+  fromResponse :: Text -> API.CreateChatCompletionResponse -> (a, FinishReason)++class (ChatCompletion a) => Validate a b where+  tryConvert :: a -> Either a b++toPV :: (ToJSON a) => a -> PersistValue+toPV = toPersistValue . toStrict . encode++fromPV :: (FromJSON a) => PersistValue -> Either Text a+fromPV json = do+  json' <- fmap fromStrict $ fromPersistValue json+  case eitherDecode json' of+    Right v -> return v+    Left err -> Left $ "Decoding JSON fails : " <> T.pack err++instance PersistField API.CreateChatCompletionRequest where+  toPersistValue = toPV+  fromPersistValue = fromPV++instance PersistFieldSql API.CreateChatCompletionRequest where+  sqlType _ = sqlType (Proxy @ByteString)++instance PersistField API.CreateChatCompletionResponse where+  toPersistValue = toPV+  fromPersistValue = fromPV++instance PersistFieldSql API.CreateChatCompletionResponse where+  sqlType _ = sqlType (Proxy @ByteString)++instance PersistField User where+  toPersistValue = toPV+  fromPersistValue = fromPV++instance PersistFieldSql User where+  sqlType _ = sqlType (Proxy @ByteString)++instance PersistField Message where+  toPersistValue = toPV+  fromPersistValue = fromPV++instance PersistFieldSql Message where+  sqlType _ = sqlType (Proxy @ByteString)++share+  [mkPersist sqlSettings, mkMigrate "migrateAll"]+  [persistLowerCase|+Content+    user User+    message Message+    sessionName Text+    created UTCTime default=CURRENT_TIME+    deriving Show+    deriving Eq+    deriving Ord+Context+    request API.CreateChatCompletionRequest+    response API.CreateChatCompletionResponse Maybe+    header [Content]+    body [Content]+    footer [Content]+    totalTokens Int+    sessionName Text+    created UTCTime default=CURRENT_TIME+    deriving Show+    deriving Eq+    deriving Ord+|]++data ToolProxy = forall t. (Tool t, A.FromJSON t, A.ToJSON t, A.FromJSON (Output t), A.ToJSON (Output t)) => ToolProxy (Proxy t)++class CustomInstruction a where+  customHeader :: Contents+  customFooter :: Contents++data CustomInstructionProxy = forall t. (CustomInstruction t) => CustomInstructionProxy (Proxy t)++data PromptEnv = PromptEnv+  { tools :: [ToolProxy],+    customInstructions :: [CustomInstructionProxy],+    context :: Context+  }++type Contents = [Content]++type Prompt = StateT PromptEnv++-- data TypedPrompt tools task output =++type SessionName = Text++defaultRequest :: API.CreateChatCompletionRequest+defaultRequest =+  API.CreateChatCompletionRequest+    { API.createChatCompletionRequestMessages = [],+      API.createChatCompletionRequestModel = API.CreateChatCompletionRequestModel "gpt-4",+      API.createChatCompletionRequestFrequencyUnderscorepenalty = Nothing,+      API.createChatCompletionRequestLogitUnderscorebias = Nothing,+      API.createChatCompletionRequestLogprobs = Nothing,+      API.createChatCompletionRequestTopUnderscorelogprobs = Nothing,+      API.createChatCompletionRequestMaxUnderscoretokens = Nothing,+      API.createChatCompletionRequestN = Nothing,+      API.createChatCompletionRequestPresenceUnderscorepenalty = Nothing,+      API.createChatCompletionRequestResponseUnderscoreformat = Nothing,+      API.createChatCompletionRequestSeed = Just 0,+      API.createChatCompletionRequestStop = Nothing,+      API.createChatCompletionRequestStream = Nothing,+      API.createChatCompletionRequestTemperature = Nothing,+      API.createChatCompletionRequestTopUnderscorep = Nothing,+      API.createChatCompletionRequestTools = Nothing,+      API.createChatCompletionRequestToolUnderscorechoice = Nothing,+      API.createChatCompletionRequestUser = Nothing,+      API.createChatCompletionRequestFunctionUnderscorecall = Nothing,+      API.createChatCompletionRequestFunctions = Nothing+    }++class Tool a where+  data Output a :: Type++  toolFunctionName :: Text+  default toolFunctionName :: (HasFunctionObject a) => Text+  toolFunctionName = T.pack $ getFunctionName @a++  toolSchema :: API.ChatCompletionTool+  default toolSchema :: (HasFunctionObject a, JSONSchema a, Generic a, GSchema a (Rep a)) => API.ChatCompletionTool+  toolSchema = toChatCompletionTool @a++  toolExec :: a -> IO (Output a)++toChatCompletionTool :: forall a. (HasFunctionObject a, JSONSchema a) => API.ChatCompletionTool+toChatCompletionTool =+  API.ChatCompletionTool+    { chatCompletionToolType = "function",+      chatCompletionToolFunction =+        API.FunctionObject+          { functionObjectDescription = Just (T.pack $ getFunctionDescription @a),+            functionObjectName = T.pack $ getFunctionName @a,+            functionObjectParameters = Just $+              case toAeson (schema @a) of+                A.Object kv -> M.fromList $ map (\(k, v) -> (A.toString k, v)) $ A.toList kv+                _ -> []+          }+    }++class HasFunctionObject r where+  getFunctionName :: String+  getFunctionDescription :: String+  getFieldDescription :: String -> String++class JSONSchema r where+  schema :: Schema+  default schema :: (HasFunctionObject r, Generic r, GSchema r (Rep r)) => Schema+  schema = gschema @r (from (undefined :: r))++class GSchema s f where+  gschema :: forall a. f a -> Schema++data Schema+  = Maybe' Schema+  | String'+  | Number'+  | Integer'+  | Object' [(String, String, Schema)]+  | Array' Schema+  | Boolean'+  | Null'++toAeson :: Schema -> A.Value+toAeson = \case+  Maybe' s -> toAeson s+  String' -> A.Object [("type", "string")]+  Number' -> A.Object [("type", "number")]+  Integer' -> A.Object [("type", "integer")]+  Object' properties ->+    let notMaybes' :: [A.Value]+        notMaybes' =+          concat $+            map+              ( \(name, desc, schema) ->+                  case schema of+                    Maybe' _ -> []+                    _ -> [A.String $ T.pack name]+              )+              properties+     in A.Object+          [ ("type", "object"),+            ( "properties",+              A.Object $+                A.fromList $+                  map+                    ( \(name, desc, schema) ->+                        (A.fromString name, append (toAeson schema) (A.Object [("description", A.String $ T.pack desc)]))+                    )+                    properties+            ),+            ("required", A.Array (V.fromList notMaybes'))+          ]+  Array' s ->+    A.Object+      [ ("type", "array"),+        ("items", toAeson s)+      ]+  Boolean' -> A.Object [("type", "boolean")]+  Null' -> A.Object [("type", "null")]++instance Semigroup Schema where+  (<>) (Object' a) (Object' b) = Object' (a <> b)+  (<>) (Array' a) (Array' b) = Array' (a <> b)+  (<>) _ _ = error "Can not concat json value."++append :: A.Value -> A.Value -> A.Value+append (A.Object a) (A.Object b) = A.Object (a <> b)+append (A.Array a) (A.Array b) = A.Array (a <> b)+append _ _ = error "Can not concat json value."++instance {-# OVERLAPS #-} JSONSchema String where+  schema = String'++instance JSONSchema Text where+  schema = String'++instance (JSONSchema a) => JSONSchema (Maybe a) where+  schema = Maybe' (schema @a)++instance JSONSchema Integer where+  schema = Integer'++instance JSONSchema Double where+  schema = Number'++instance JSONSchema Bool where+  schema = Boolean'++instance (JSONSchema a) => JSONSchema [a] where+  schema = Array' (schema @a)++instance JSONSchema () where+  schema = Null'++instance (HasFunctionObject s, JSONSchema c) => GSchema s U1 where+  gschema _ = Null'++instance (HasFunctionObject s, JSONSchema c) => GSchema s (K1 i c) where+  gschema _ = schema @c++instance (HasFunctionObject s, GSchema s a, GSchema s b) => GSchema s (a :*: b) where+  gschema _ = gschema @s @a undefined <> gschema @s @b undefined++instance (HasFunctionObject s, GSchema s a, GSchema s b) => GSchema s (a :+: b) where+  gschema _ = gschema @s @a undefined+  gschema _ = gschema @s @b undefined++-- | Datatype+instance (HasFunctionObject s, GSchema s f) => GSchema s (M1 D c f) where+  gschema _ = gschema @s @f undefined++-- | Constructor Metadata+instance (HasFunctionObject s, GSchema s f, Constructor c) => GSchema s (M1 C c f) where+  gschema _ = gschema @s @f undefined++-- | Selector Metadata+instance (HasFunctionObject s, GSchema s f, Selector c) => GSchema s (M1 S c f) where+  gschema a =+    let name = selName a+        desc = getFieldDescription @s name+     in Object' [(name, desc, (gschema @s @f undefined))]++toolAdd :: forall a. (Tool a) => API.CreateChatCompletionRequest -> API.CreateChatCompletionRequest+toolAdd req =+  let prevTools = case API.createChatCompletionRequestTools req of+        Nothing -> []+        Just v -> v+      newTools = prevTools ++ [toolSchema @a]+   in req {API.createChatCompletionRequestTools = Just newTools}++defaultUTCTime :: UTCTime+defaultUTCTime = UTCTime (coerce (0 :: Integer)) 0
+ test/Main.hs view
@@ -0,0 +1,4 @@+module Main (main) where++main :: IO ()+main = putStrLn "Test suite not yet implemented."