{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} {-# 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 #-} {-# LANGUAGE ExistentialQuantification #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module IntelliMonad.Types where import qualified Codec.Picture as P import Control.Monad.IO.Class 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)