{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# 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 (User -> User -> Bool
(User -> User -> Bool) -> (User -> User -> Bool) -> Eq User
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: User -> User -> Bool
== :: User -> User -> Bool
$c/= :: User -> User -> Bool
/= :: User -> User -> Bool
Eq, Int -> User -> ShowS
[User] -> ShowS
User -> String
(Int -> User -> ShowS)
-> (User -> String) -> ([User] -> ShowS) -> Show User
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> User -> ShowS
showsPrec :: Int -> User -> ShowS
$cshow :: User -> String
show :: User -> String
$cshowList :: [User] -> ShowS
showList :: [User] -> ShowS
Show, Eq User
Eq User =>
(User -> User -> Ordering)
-> (User -> User -> Bool)
-> (User -> User -> Bool)
-> (User -> User -> Bool)
-> (User -> User -> Bool)
-> (User -> User -> User)
-> (User -> User -> User)
-> Ord User
User -> User -> Bool
User -> User -> Ordering
User -> User -> User
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: User -> User -> Ordering
compare :: User -> User -> Ordering
$c< :: User -> User -> Bool
< :: User -> User -> Bool
$c<= :: User -> User -> Bool
<= :: User -> User -> Bool
$c> :: User -> User -> Bool
> :: User -> User -> Bool
$c>= :: User -> User -> Bool
>= :: User -> User -> Bool
$cmax :: User -> User -> User
max :: User -> User -> User
$cmin :: User -> User -> User
min :: User -> User -> User
Ord, (forall x. User -> Rep User x)
-> (forall x. Rep User x -> User) -> Generic User
forall x. Rep User x -> User
forall x. User -> Rep User x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. User -> Rep User x
from :: forall x. User -> Rep User x
$cto :: forall x. Rep User x -> User
to :: forall x. Rep User x -> User
Generic)

instance ToJSON User

instance FromJSON User

userToText :: User -> Text
userToText :: User -> Text
userToText = \case
  User
User -> Text
"user"
  User
System -> Text
"system"
  User
Assistant -> Text
"assistant"
  User
Tool -> Text
"tool"

textToUser :: Text -> User
textToUser :: Text -> User
textToUser = \case
  Text
"user" -> User
User
  Text
"system" -> User
System
  Text
"assistant" -> User
Assistant
  Text
"tool" -> User
Tool
  Text
v -> String -> User
forall a. HasCallStack => String -> a
error (String -> User) -> String -> User
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"Undefined role:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v

instance Show (P.Image P.PixelRGB8) where
  show :: Image PixelRGB8 -> String
show Image PixelRGB8
_ = String
"Image: ..."

data Message
  = Message
      {Message -> Text
unText :: Text}
  | Image
      { Message -> Text
imageType :: Text,
        Message -> Text
imageData :: Text
      }
  | ToolCall
      { Message -> Text
toolId :: Text,
        Message -> Text
toolName :: Text,
        Message -> Text
toolArguments :: Text
      }
  | ToolReturn
      { toolId :: Text,
        toolName :: Text,
        Message -> Text
toolContent :: Text
      }
  deriving (Message -> Message -> Bool
(Message -> Message -> Bool)
-> (Message -> Message -> Bool) -> Eq Message
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Message -> Message -> Bool
== :: Message -> Message -> Bool
$c/= :: Message -> Message -> Bool
/= :: Message -> Message -> Bool
Eq, Int -> Message -> ShowS
[Message] -> ShowS
Message -> String
(Int -> Message -> ShowS)
-> (Message -> String) -> ([Message] -> ShowS) -> Show Message
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Message -> ShowS
showsPrec :: Int -> Message -> ShowS
$cshow :: Message -> String
show :: Message -> String
$cshowList :: [Message] -> ShowS
showList :: [Message] -> ShowS
Show, Eq Message
Eq Message =>
(Message -> Message -> Ordering)
-> (Message -> Message -> Bool)
-> (Message -> Message -> Bool)
-> (Message -> Message -> Bool)
-> (Message -> Message -> Bool)
-> (Message -> Message -> Message)
-> (Message -> Message -> Message)
-> Ord Message
Message -> Message -> Bool
Message -> Message -> Ordering
Message -> Message -> Message
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Message -> Message -> Ordering
compare :: Message -> Message -> Ordering
$c< :: Message -> Message -> Bool
< :: Message -> Message -> Bool
$c<= :: Message -> Message -> Bool
<= :: Message -> Message -> Bool
$c> :: Message -> Message -> Bool
> :: Message -> Message -> Bool
$c>= :: Message -> Message -> Bool
>= :: Message -> Message -> Bool
$cmax :: Message -> Message -> Message
max :: Message -> Message -> Message
$cmin :: Message -> Message -> Message
min :: Message -> Message -> Message
Ord, (forall x. Message -> Rep Message x)
-> (forall x. Rep Message x -> Message) -> Generic Message
forall x. Rep Message x -> Message
forall x. Message -> Rep Message x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Message -> Rep Message x
from :: forall x. Message -> Rep Message x
$cto :: forall x. Rep Message x -> Message
to :: forall x. Rep Message x -> Message
Generic)

data FinishReason
  = Stop
  | Length
  | ToolCalls
  | FunctionCall
  | ContentFilter
  | Null
  deriving (FinishReason -> FinishReason -> Bool
(FinishReason -> FinishReason -> Bool)
-> (FinishReason -> FinishReason -> Bool) -> Eq FinishReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FinishReason -> FinishReason -> Bool
== :: FinishReason -> FinishReason -> Bool
$c/= :: FinishReason -> FinishReason -> Bool
/= :: FinishReason -> FinishReason -> Bool
Eq, Int -> FinishReason -> ShowS
[FinishReason] -> ShowS
FinishReason -> String
(Int -> FinishReason -> ShowS)
-> (FinishReason -> String)
-> ([FinishReason] -> ShowS)
-> Show FinishReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FinishReason -> ShowS
showsPrec :: Int -> FinishReason -> ShowS
$cshow :: FinishReason -> String
show :: FinishReason -> String
$cshowList :: [FinishReason] -> ShowS
showList :: [FinishReason] -> ShowS
Show)

finishReasonToText :: FinishReason -> Text
finishReasonToText :: FinishReason -> Text
finishReasonToText = \case
  FinishReason
Stop -> Text
"stop"
  FinishReason
Length -> Text
"length"
  FinishReason
ToolCalls -> Text
"tool_calls"
  FinishReason
FunctionCall -> Text
"function_call"
  FinishReason
ContentFilter -> Text
"content_fileter"
  FinishReason
Null -> Text
"null"

textToFinishReason :: Text -> FinishReason
textToFinishReason :: Text -> FinishReason
textToFinishReason = \case
  Text
"stop" -> FinishReason
Stop
  Text
"length" -> FinishReason
Length
  Text
"tool_calls" -> FinishReason
ToolCalls
  Text
"function_call" -> FinishReason
FunctionCall
  Text
"content_filter" -> FinishReason
ContentFilter
  Text
"null" -> FinishReason
Null
  Text
_ -> FinishReason
Null

instance ToJSON Message

instance FromJSON Message

newtype Model = Model Text deriving (Model -> Model -> Bool
(Model -> Model -> Bool) -> (Model -> Model -> Bool) -> Eq Model
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Model -> Model -> Bool
== :: Model -> Model -> Bool
$c/= :: Model -> Model -> Bool
/= :: Model -> Model -> Bool
Eq, Int -> Model -> ShowS
[Model] -> ShowS
Model -> String
(Int -> Model -> ShowS)
-> (Model -> String) -> ([Model] -> ShowS) -> Show Model
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Model -> ShowS
showsPrec :: Int -> Model -> ShowS
$cshow :: Model -> String
show :: Model -> String
$cshowList :: [Model] -> ShowS
showList :: [Model] -> ShowS
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 :: forall a. ToJSON a => a -> PersistValue
toPV = ByteString -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue (ByteString -> PersistValue)
-> (a -> ByteString) -> a -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
toStrict (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
encode

fromPV :: (FromJSON a) => PersistValue -> Either Text a
fromPV :: forall a. FromJSON a => PersistValue -> Either Text a
fromPV PersistValue
json = do
  ByteString
json' <- (ByteString -> ByteString)
-> Either Text ByteString -> Either Text ByteString
forall a b. (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
fromStrict (Either Text ByteString -> Either Text ByteString)
-> Either Text ByteString -> Either Text ByteString
forall a b. (a -> b) -> a -> b
$ PersistValue -> Either Text ByteString
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
json
  case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
json' of
    Right a
v -> a -> Either Text a
forall a. a -> Either Text a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
    Left String
err -> Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text
"Decoding JSON fails : " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err

instance PersistField API.CreateChatCompletionRequest where
  toPersistValue :: CreateChatCompletionRequest -> PersistValue
toPersistValue = CreateChatCompletionRequest -> PersistValue
forall a. ToJSON a => a -> PersistValue
toPV
  fromPersistValue :: PersistValue -> Either Text CreateChatCompletionRequest
fromPersistValue = PersistValue -> Either Text CreateChatCompletionRequest
forall a. FromJSON a => PersistValue -> Either Text a
fromPV

instance PersistFieldSql API.CreateChatCompletionRequest where
  sqlType :: Proxy CreateChatCompletionRequest -> SqlType
sqlType Proxy CreateChatCompletionRequest
_ = Proxy ByteString -> SqlType
forall a. PersistFieldSql a => Proxy a -> SqlType
sqlType (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @ByteString)

instance PersistField API.CreateChatCompletionResponse where
  toPersistValue :: CreateChatCompletionResponse -> PersistValue
toPersistValue = CreateChatCompletionResponse -> PersistValue
forall a. ToJSON a => a -> PersistValue
toPV
  fromPersistValue :: PersistValue -> Either Text CreateChatCompletionResponse
fromPersistValue = PersistValue -> Either Text CreateChatCompletionResponse
forall a. FromJSON a => PersistValue -> Either Text a
fromPV

instance PersistFieldSql API.CreateChatCompletionResponse where
  sqlType :: Proxy CreateChatCompletionResponse -> SqlType
sqlType Proxy CreateChatCompletionResponse
_ = Proxy ByteString -> SqlType
forall a. PersistFieldSql a => Proxy a -> SqlType
sqlType (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @ByteString)

instance PersistField User where
  toPersistValue :: User -> PersistValue
toPersistValue = User -> PersistValue
forall a. ToJSON a => a -> PersistValue
toPV
  fromPersistValue :: PersistValue -> Either Text User
fromPersistValue = PersistValue -> Either Text User
forall a. FromJSON a => PersistValue -> Either Text a
fromPV

instance PersistFieldSql User where
  sqlType :: Proxy User -> SqlType
sqlType Proxy User
_ = Proxy ByteString -> SqlType
forall a. PersistFieldSql a => Proxy a -> SqlType
sqlType (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @ByteString)

instance PersistField Message where
  toPersistValue :: Message -> PersistValue
toPersistValue = Message -> PersistValue
forall a. ToJSON a => a -> PersistValue
toPV
  fromPersistValue :: PersistValue -> Either Text Message
fromPersistValue = PersistValue -> Either Text Message
forall a. FromJSON a => PersistValue -> Either Text a
fromPV

instance PersistFieldSql Message where
  sqlType :: Proxy Message -> SqlType
sqlType Proxy Message
_ = Proxy ByteString -> SqlType
forall a. PersistFieldSql a => Proxy a -> SqlType
sqlType (forall t. Proxy t
forall {k} (t :: k). Proxy t
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
    deriving ToJSON
    deriving FromJSON
    deriving Generic
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
  { PromptEnv -> [ToolProxy]
tools :: [ToolProxy],
    PromptEnv -> [CustomInstructionProxy]
customInstructions :: [CustomInstructionProxy],
    PromptEnv -> Context
context :: Context
  }

type Contents = [Content]

type Prompt = StateT PromptEnv

-- data TypedPrompt tools task output =

type SessionName = Text

defaultRequest :: API.CreateChatCompletionRequest
defaultRequest :: CreateChatCompletionRequest
defaultRequest =
  API.CreateChatCompletionRequest
    { createChatCompletionRequestMessages :: [ChatCompletionRequestMessage]
API.createChatCompletionRequestMessages = [],
      createChatCompletionRequestModel :: CreateChatCompletionRequestModel
API.createChatCompletionRequestModel = Text -> CreateChatCompletionRequestModel
API.CreateChatCompletionRequestModel Text
"gpt-4",
      createChatCompletionRequestFrequencyUnderscorepenalty :: Maybe Double
API.createChatCompletionRequestFrequencyUnderscorepenalty = Maybe Double
forall a. Maybe a
Nothing,
      createChatCompletionRequestLogitUnderscorebias :: Maybe (Map String Int)
API.createChatCompletionRequestLogitUnderscorebias = Maybe (Map String Int)
forall a. Maybe a
Nothing,
      createChatCompletionRequestLogprobs :: Maybe Bool
API.createChatCompletionRequestLogprobs = Maybe Bool
forall a. Maybe a
Nothing,
      createChatCompletionRequestTopUnderscorelogprobs :: Maybe Int
API.createChatCompletionRequestTopUnderscorelogprobs = Maybe Int
forall a. Maybe a
Nothing,
      createChatCompletionRequestMaxUnderscoretokens :: Maybe Int
API.createChatCompletionRequestMaxUnderscoretokens = Maybe Int
forall a. Maybe a
Nothing,
      createChatCompletionRequestN :: Maybe Int
API.createChatCompletionRequestN = Maybe Int
forall a. Maybe a
Nothing,
      createChatCompletionRequestPresenceUnderscorepenalty :: Maybe Double
API.createChatCompletionRequestPresenceUnderscorepenalty = Maybe Double
forall a. Maybe a
Nothing,
      createChatCompletionRequestResponseUnderscoreformat :: Maybe CreateChatCompletionRequestResponseFormat
API.createChatCompletionRequestResponseUnderscoreformat = Maybe CreateChatCompletionRequestResponseFormat
forall a. Maybe a
Nothing,
      createChatCompletionRequestSeed :: Maybe Int
API.createChatCompletionRequestSeed = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0,
      createChatCompletionRequestStop :: Maybe CreateChatCompletionRequestStop
API.createChatCompletionRequestStop = Maybe CreateChatCompletionRequestStop
forall a. Maybe a
Nothing,
      createChatCompletionRequestStream :: Maybe Bool
API.createChatCompletionRequestStream = Maybe Bool
forall a. Maybe a
Nothing,
      createChatCompletionRequestTemperature :: Maybe Double
API.createChatCompletionRequestTemperature = Maybe Double
forall a. Maybe a
Nothing,
      createChatCompletionRequestTopUnderscorep :: Maybe Double
API.createChatCompletionRequestTopUnderscorep = Maybe Double
forall a. Maybe a
Nothing,
      createChatCompletionRequestTools :: Maybe [ChatCompletionTool]
API.createChatCompletionRequestTools = Maybe [ChatCompletionTool]
forall a. Maybe a
Nothing,
      createChatCompletionRequestToolUnderscorechoice :: Maybe ChatCompletionToolChoiceOption
API.createChatCompletionRequestToolUnderscorechoice = Maybe ChatCompletionToolChoiceOption
forall a. Maybe a
Nothing,
      createChatCompletionRequestUser :: Maybe Text
API.createChatCompletionRequestUser = Maybe Text
forall a. Maybe a
Nothing,
      createChatCompletionRequestFunctionUnderscorecall :: Maybe CreateChatCompletionRequestFunctionCall
API.createChatCompletionRequestFunctionUnderscorecall = Maybe CreateChatCompletionRequestFunctionCall
forall a. Maybe a
Nothing,
      createChatCompletionRequestFunctions :: Maybe [ChatCompletionFunctions]
API.createChatCompletionRequestFunctions = Maybe [ChatCompletionFunctions]
forall a. Maybe a
Nothing
    }

class Tool a where
  data Output a :: Type

  toolFunctionName :: Text
  default toolFunctionName :: (HasFunctionObject a) => Text
  toolFunctionName = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ forall r. HasFunctionObject r => String
getFunctionName @a

  toolSchema :: API.ChatCompletionTool
  default toolSchema :: (HasFunctionObject a, JSONSchema a, Generic a, GSchema a (Rep a)) => API.ChatCompletionTool
  toolSchema = forall a. (HasFunctionObject a, JSONSchema a) => ChatCompletionTool
toChatCompletionTool @a

  toolExec :: a -> IO (Output a)

toChatCompletionTool :: forall a. (HasFunctionObject a, JSONSchema a) => API.ChatCompletionTool
toChatCompletionTool :: forall a. (HasFunctionObject a, JSONSchema a) => ChatCompletionTool
toChatCompletionTool =
  API.ChatCompletionTool
    { chatCompletionToolType :: Text
chatCompletionToolType = Text
"function",
      chatCompletionToolFunction :: FunctionObject
chatCompletionToolFunction =
        API.FunctionObject
          { functionObjectDescription :: Maybe Text
functionObjectDescription = Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ forall r. HasFunctionObject r => String
getFunctionDescription @a),
            functionObjectName :: Text
functionObjectName = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ forall r. HasFunctionObject r => String
getFunctionName @a,
            functionObjectParameters :: Maybe (Map String Value)
functionObjectParameters = Map String Value -> Maybe (Map String Value)
forall a. a -> Maybe a
Just (Map String Value -> Maybe (Map String Value))
-> Map String Value -> Maybe (Map String Value)
forall a b. (a -> b) -> a -> b
$
              case Schema -> Value
toAeson (forall r. JSONSchema r => Schema
schema @a) of
                A.Object Object
kv -> [(String, Value)] -> Map String Value
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(String, Value)] -> Map String Value)
-> [(String, Value)] -> Map String Value
forall a b. (a -> b) -> a -> b
$ (Pair -> (String, Value)) -> [Pair] -> [(String, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Key
k, Value
v) -> (Key -> String
A.toString Key
k, Value
v)) ([Pair] -> [(String, Value)]) -> [Pair] -> [(String, Value)]
forall a b. (a -> b) -> a -> b
$ Object -> [Pair]
forall v. KeyMap v -> [(Key, v)]
A.toList Object
kv
                Value
_ -> []
          }
    }

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 = forall s (f :: * -> *) a. GSchema s f => f a -> Schema
gschema @r (r -> Rep r Any
forall x. r -> Rep r x
forall a x. Generic a => a -> Rep a x
from (r
forall a. HasCallStack => a
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 :: Schema -> Value
toAeson = \case
  Maybe' Schema
s -> Schema -> Value
toAeson Schema
s
  Schema
String' -> Object -> Value
A.Object [(Key
"type", Value
"string")]
  Schema
Number' -> Object -> Value
A.Object [(Key
"type", Value
"number")]
  Schema
Integer' -> Object -> Value
A.Object [(Key
"type", Value
"integer")]
  Object' [(String, String, Schema)]
properties ->
    let notMaybes' :: [A.Value]
        notMaybes' :: [Value]
notMaybes' =
          [[Value]] -> [Value]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Value]] -> [Value]) -> [[Value]] -> [Value]
forall a b. (a -> b) -> a -> b
$
            ((String, String, Schema) -> [Value])
-> [(String, String, Schema)] -> [[Value]]
forall a b. (a -> b) -> [a] -> [b]
map
              ( \(String
name, String
desc, Schema
schema) ->
                  case Schema
schema of
                    Maybe' Schema
_ -> []
                    Schema
_ -> [Text -> Value
A.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
name]
              )
              [(String, String, Schema)]
properties
     in Object -> Value
A.Object
          [ (Key
"type", Value
"object"),
            ( Key
"properties",
              Object -> Value
A.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$
                [Pair] -> Object
forall v. [(Key, v)] -> KeyMap v
A.fromList ([Pair] -> Object) -> [Pair] -> Object
forall a b. (a -> b) -> a -> b
$
                  ((String, String, Schema) -> Pair)
-> [(String, String, Schema)] -> [Pair]
forall a b. (a -> b) -> [a] -> [b]
map
                    ( \(String
name, String
desc, Schema
schema) ->
                        (String -> Key
A.fromString String
name, Value -> Value -> Value
append (Schema -> Value
toAeson Schema
schema) (Object -> Value
A.Object [(Key
"description", Text -> Value
A.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
desc)]))
                    )
                    [(String, String, Schema)]
properties
            ),
            (Key
"required", Array -> Value
A.Array ([Value] -> Array
forall a. [a] -> Vector a
V.fromList [Value]
notMaybes'))
          ]
  Array' Schema
s ->
    Object -> Value
A.Object
      [ (Key
"type", Value
"array"),
        (Key
"items", Schema -> Value
toAeson Schema
s)
      ]
  Schema
Boolean' -> Object -> Value
A.Object [(Key
"type", Value
"boolean")]
  Schema
Null' -> Object -> Value
A.Object [(Key
"type", Value
"null")]

instance Semigroup Schema where
  <> :: Schema -> Schema -> Schema
(<>) (Object' [(String, String, Schema)]
a) (Object' [(String, String, Schema)]
b) = [(String, String, Schema)] -> Schema
Object' ([(String, String, Schema)]
a [(String, String, Schema)]
-> [(String, String, Schema)] -> [(String, String, Schema)]
forall a. Semigroup a => a -> a -> a
<> [(String, String, Schema)]
b)
  (<>) (Array' Schema
a) (Array' Schema
b) = Schema -> Schema
Array' (Schema
a Schema -> Schema -> Schema
forall a. Semigroup a => a -> a -> a
<> Schema
b)
  (<>) Schema
_ Schema
_ = String -> Schema
forall a. HasCallStack => String -> a
error String
"Can not concat json value."

append :: A.Value -> A.Value -> A.Value
append :: Value -> Value -> Value
append (A.Object Object
a) (A.Object Object
b) = Object -> Value
A.Object (Object
a Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<> Object
b)
append (A.Array Array
a) (A.Array Array
b) = Array -> Value
A.Array (Array
a Array -> Array -> Array
forall a. Semigroup a => a -> a -> a
<> Array
b)
append Value
_ Value
_ = String -> Value
forall a. HasCallStack => String -> a
error String
"Can not concat json value."

instance {-# OVERLAPS #-} JSONSchema String where
  schema :: Schema
schema = Schema
String'

instance JSONSchema Text where
  schema :: Schema
schema = Schema
String'

instance (JSONSchema a) => JSONSchema (Maybe a) where
  schema :: Schema
schema = Schema -> Schema
Maybe' (forall r. JSONSchema r => Schema
schema @a)

instance JSONSchema Integer where
  schema :: Schema
schema = Schema
Integer'

instance JSONSchema Int where
  schema :: Schema
schema = Schema
Integer'

instance JSONSchema Double where
  schema :: Schema
schema = Schema
Number'

instance JSONSchema Bool where
  schema :: Schema
schema = Schema
Boolean'

instance (JSONSchema a) => JSONSchema [a] where
  schema :: Schema
schema = Schema -> Schema
Array' (forall r. JSONSchema r => Schema
schema @a)

instance JSONSchema () where
  schema :: Schema
schema = Schema
Null'

instance (HasFunctionObject s, JSONSchema c) => GSchema s U1 where
  gschema :: forall a. U1 a -> Schema
gschema U1 a
_ = Schema
Null'

instance (HasFunctionObject s, JSONSchema c) => GSchema s (K1 i c) where
  gschema :: forall a. K1 i c a -> Schema
gschema K1 i c a
_ = forall r. JSONSchema r => Schema
schema @c

instance (HasFunctionObject s, GSchema s a, GSchema s b) => GSchema s (a :*: b) where
  gschema :: forall a. (:*:) a b a -> Schema
gschema (:*:) a b a
_ = forall s (f :: * -> *) a. GSchema s f => f a -> Schema
gschema @s @a a Any
forall a. HasCallStack => a
undefined Schema -> Schema -> Schema
forall a. Semigroup a => a -> a -> a
<> forall s (f :: * -> *) a. GSchema s f => f a -> Schema
gschema @s @b b Any
forall a. HasCallStack => a
undefined

instance (HasFunctionObject s, GSchema s a, GSchema s b) => GSchema s (a :+: b) where
  gschema :: forall a. (:+:) a b a -> Schema
gschema (:+:) a b a
_ = forall s (f :: * -> *) a. GSchema s f => f a -> Schema
gschema @s @a a Any
forall a. HasCallStack => a
undefined
  gschema (:+:) a b a
_ = forall s (f :: * -> *) a. GSchema s f => f a -> Schema
gschema @s @b b Any
forall a. HasCallStack => a
undefined

-- | Datatype
instance (HasFunctionObject s, GSchema s f) => GSchema s (M1 D c f) where
  gschema :: forall a. M1 D c f a -> Schema
gschema M1 D c f a
_ = forall s (f :: * -> *) a. GSchema s f => f a -> Schema
gschema @s @f f Any
forall a. HasCallStack => a
undefined

-- | Constructor Metadata
instance (HasFunctionObject s, GSchema s f, Constructor c) => GSchema s (M1 C c f) where
  gschema :: forall a. M1 C c f a -> Schema
gschema M1 C c f a
_ = forall s (f :: * -> *) a. GSchema s f => f a -> Schema
gschema @s @f f Any
forall a. HasCallStack => a
undefined

-- | Selector Metadata
instance (HasFunctionObject s, GSchema s f, Selector c) => GSchema s (M1 S c f) where
  gschema :: forall a. M1 S c f a -> Schema
gschema M1 S c f a
a =
    let name :: String
name = M1 S c f a -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t c f a -> String
selName M1 S c f a
a
        desc :: String
desc = forall r. HasFunctionObject r => ShowS
getFieldDescription @s String
name
     in [(String, String, Schema)] -> Schema
Object' [(String
name, String
desc, (forall s (f :: * -> *) a. GSchema s f => f a -> Schema
gschema @s @f f Any
forall a. HasCallStack => a
undefined))]

toolAdd :: forall a. (Tool a) => API.CreateChatCompletionRequest -> API.CreateChatCompletionRequest
toolAdd :: forall a.
Tool a =>
CreateChatCompletionRequest -> CreateChatCompletionRequest
toolAdd CreateChatCompletionRequest
req =
  let prevTools :: [ChatCompletionTool]
prevTools = case CreateChatCompletionRequest -> Maybe [ChatCompletionTool]
API.createChatCompletionRequestTools CreateChatCompletionRequest
req of
        Maybe [ChatCompletionTool]
Nothing -> []
        Just [ChatCompletionTool]
v -> [ChatCompletionTool]
v
      newTools :: [ChatCompletionTool]
newTools = [ChatCompletionTool]
prevTools [ChatCompletionTool]
-> [ChatCompletionTool] -> [ChatCompletionTool]
forall a. [a] -> [a] -> [a]
++ [forall a. Tool a => ChatCompletionTool
toolSchema @a]
   in CreateChatCompletionRequest
req {API.createChatCompletionRequestTools = Just newTools}

defaultUTCTime :: UTCTime
defaultUTCTime :: UTCTime
defaultUTCTime = Day -> DiffTime -> UTCTime
UTCTime (Integer -> Day
forall a b. Coercible a b => a -> b
coerce (Integer
0 :: Integer)) DiffTime
0

data ReplCommand
  = Quit
  | Clear
  | ShowContents
  | ShowUsage
  | ShowRequest
  | ShowContext
  | ShowSession
  | Edit
  | EditRequest
  | EditContents
  | EditHeader
  | EditFooter
  | ListSessions
  | CopySession
  { ReplCommand -> Text
sessionNameFrom :: Text
  , ReplCommand -> Text
sessionNameTo :: Text
  }
  | DeleteSession
  { ReplCommand -> Text
sessionName :: Text
  }
  | SwitchSession
  { sessionName :: Text
  }
  | ReadImage Text
  | UserInput Text
  | Help
  | Repl 
  { sessionName :: Text
  }
  deriving (ReplCommand -> ReplCommand -> Bool
(ReplCommand -> ReplCommand -> Bool)
-> (ReplCommand -> ReplCommand -> Bool) -> Eq ReplCommand
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReplCommand -> ReplCommand -> Bool
== :: ReplCommand -> ReplCommand -> Bool
$c/= :: ReplCommand -> ReplCommand -> Bool
/= :: ReplCommand -> ReplCommand -> Bool
Eq, Int -> ReplCommand -> ShowS
[ReplCommand] -> ShowS
ReplCommand -> String
(Int -> ReplCommand -> ShowS)
-> (ReplCommand -> String)
-> ([ReplCommand] -> ShowS)
-> Show ReplCommand
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ReplCommand -> ShowS
showsPrec :: Int -> ReplCommand -> ShowS
$cshow :: ReplCommand -> String
show :: ReplCommand -> String
$cshowList :: [ReplCommand] -> ShowS
showList :: [ReplCommand] -> ShowS
Show)