{-# LANGUAGE TemplateHaskell #-}
module Calamity.Commands.Context (
CalamityCommandContext (..),
FullContext (..),
useFullContext,
LightContext (..),
useLightContext,
) where
import Calamity.Cache.Eff
import Calamity.Commands.Types
import Calamity.Internal.Utils
import Calamity.Types.Model.Channel
import Calamity.Types.Model.Guild
import Calamity.Types.Model.User
import Calamity.Types.Snowflake
import Calamity.Types.Tellable
import qualified CalamityCommands.Context as CC
import Control.Applicative
import Control.Monad
import qualified Data.Text as T
import Optics
import qualified Polysemy as P
import qualified Polysemy.Fail as P
import qualified TextShow
class CommandContext c => CalamityCommandContext c where
ctxChannelID :: c -> Snowflake Channel
ctxGuildID :: c -> Maybe (Snowflake Guild)
ctxUserID :: c -> Snowflake User
ctxMessage :: c -> Message
data FullContext = FullContext
{
FullContext -> Message
message :: Message
,
FullContext -> Maybe Guild
guild :: Maybe Guild
,
FullContext -> Maybe Member
member :: Maybe Member
,
FullContext -> Channel
channel :: Channel
,
FullContext -> User
user :: User
,
FullContext -> Command FullContext
command :: Command FullContext
,
FullContext -> Text
prefix :: T.Text
,
FullContext -> Text
unparsedParams :: T.Text
}
deriving (Int -> FullContext -> ShowS
[FullContext] -> ShowS
FullContext -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FullContext] -> ShowS
$cshowList :: [FullContext] -> ShowS
show :: FullContext -> String
$cshow :: FullContext -> String
showsPrec :: Int -> FullContext -> ShowS
$cshowsPrec :: Int -> FullContext -> ShowS
Show)
deriving (Int -> FullContext -> Builder
Int -> FullContext -> Text
Int -> FullContext -> Text
[FullContext] -> Builder
[FullContext] -> Text
[FullContext] -> Text
FullContext -> Builder
FullContext -> Text
FullContext -> Text
forall a.
(Int -> a -> Builder)
-> (a -> Builder)
-> ([a] -> Builder)
-> (Int -> a -> Text)
-> (a -> Text)
-> ([a] -> Text)
-> (Int -> a -> Text)
-> (a -> Text)
-> ([a] -> Text)
-> TextShow a
showtlList :: [FullContext] -> Text
$cshowtlList :: [FullContext] -> Text
showtl :: FullContext -> Text
$cshowtl :: FullContext -> Text
showtlPrec :: Int -> FullContext -> Text
$cshowtlPrec :: Int -> FullContext -> Text
showtList :: [FullContext] -> Text
$cshowtList :: [FullContext] -> Text
showt :: FullContext -> Text
$cshowt :: FullContext -> Text
showtPrec :: Int -> FullContext -> Text
$cshowtPrec :: Int -> FullContext -> Text
showbList :: [FullContext] -> Builder
$cshowbList :: [FullContext] -> Builder
showb :: FullContext -> Builder
$cshowb :: FullContext -> Builder
showbPrec :: Int -> FullContext -> Builder
$cshowbPrec :: Int -> FullContext -> Builder
TextShow.TextShow) via TextShow.FromStringShow FullContext
deriving (HasID Channel) via HasIDField "channel" FullContext
deriving (HasID Message) via HasIDField "message" FullContext
deriving (HasID User) via HasIDField "user" FullContext
$(makeFieldLabelsNoPrefix ''FullContext)
instance CC.CommandContext IO FullContext () where
ctxPrefix :: FullContext -> Text
ctxPrefix = (forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "prefix" a => a
#prefix)
ctxCommand :: FullContext -> Command FullContext
ctxCommand = (forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "command" a => a
#command)
ctxUnparsedParams :: FullContext -> Text
ctxUnparsedParams = (forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "unparsedParams" a => a
#unparsedParams)
instance CalamityCommandContext FullContext where
ctxChannelID :: FullContext -> Snowflake Channel
ctxChannelID = forall b a. HasID b a => a -> Snowflake b
getID forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "channel" a => a
#channel)
ctxGuildID :: FullContext -> Maybe (Snowflake Guild)
ctxGuildID FullContext
c = forall b a. HasID b a => a -> Snowflake b
getID forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FullContext
c forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "guild" a => a
#guild
ctxUserID :: FullContext -> Snowflake User
ctxUserID = forall b a. HasID b a => a -> Snowflake b
getID forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "user" a => a
#user)
ctxMessage :: FullContext -> Message
ctxMessage = (forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "message" a => a
#message)
instance Tellable FullContext where
getChannel :: forall (r :: EffectRow).
(BotC r, Member (Error RestError) r) =>
FullContext -> Sem r (Snowflake Channel)
getChannel = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. CalamityCommandContext c => c -> Snowflake Channel
ctxChannelID
useFullContext :: P.Member CacheEff r => P.Sem (CC.ConstructContext (Message, User, Maybe Member) FullContext IO () ': r) a -> P.Sem r a
useFullContext :: forall (r :: EffectRow) a.
Member CacheEff r =>
Sem
(ConstructContext (Message, User, Maybe Member) FullContext IO ()
: r)
a
-> Sem r a
useFullContext =
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
P.interpret
( \case
CC.ConstructContext (Text
pre, Command FullContext
cmd, Text
up) (Message
msg, User
usr, Maybe Member
mem) -> forall (r :: EffectRow).
Member CacheEff r =>
Message
-> User
-> Maybe Member
-> Text
-> Command FullContext
-> Text
-> Sem r (Maybe FullContext)
buildContext Message
msg User
usr Maybe Member
mem Text
pre Command FullContext
cmd Text
up
)
buildContext :: P.Member CacheEff r => Message -> User -> Maybe Member -> T.Text -> Command FullContext -> T.Text -> P.Sem r (Maybe FullContext)
buildContext :: forall (r :: EffectRow).
Member CacheEff r =>
Message
-> User
-> Maybe Member
-> Text
-> Command FullContext
-> Text
-> Sem r (Maybe FullContext)
buildContext Message
msg User
usr Maybe Member
mem Text
prefix Command FullContext
command Text
unparsed = (forall e a. Either e a -> Maybe a
rightToMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: EffectRow) a.
Sem (Fail : r) a -> Sem r (Either String a)
P.runFail forall a b. (a -> b) -> a -> b
$ do
Maybe Guild
guild <- forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (r :: EffectRow).
Member CacheEff r =>
Snowflake Guild -> Sem r (Maybe Guild)
getGuild forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
`traverse` (Message
msg forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "guildID" a => a
#guildID)
let member :: Maybe Member
member = Maybe Member
mem forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Guild
guild forall k s (is :: IxList) a.
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall a. IsLabel "members" a => a
#members forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall m. Ixed m => Index m -> Optic' (IxKind m) NoIx m (IxValue m)
ix (forall a b. Snowflake a -> Snowflake b
coerceSnowflake forall a b. (a -> b) -> a -> b
$ forall b a. HasID b a => a -> Snowflake b
getID @User Message
msg)
let gchan :: Maybe GuildChannel
gchan = Maybe Guild
guild forall k s (is :: IxList) a.
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall a. IsLabel "channels" a => a
#channels forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall m. Ixed m => Index m -> Optic' (IxKind m) NoIx m (IxValue m)
ix (forall a b. Snowflake a -> Snowflake b
coerceSnowflake forall a b. (a -> b) -> a -> b
$ forall b a. HasID b a => a -> Snowflake b
getID @Channel Message
msg)
Just Channel
channel <- case Maybe GuildChannel
gchan of
Just GuildChannel
chan -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ GuildChannel -> Channel
GuildChannel' GuildChannel
chan
Maybe GuildChannel
Nothing -> DMChannel -> Channel
DMChannel' forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<<$>> forall (r :: EffectRow).
Member CacheEff r =>
Snowflake DMChannel -> Sem r (Maybe DMChannel)
getDM (forall a b. Snowflake a -> Snowflake b
coerceSnowflake forall a b. (a -> b) -> a -> b
$ forall b a. HasID b a => a -> Snowflake b
getID @Channel Message
msg)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Message
-> Maybe Guild
-> Maybe Member
-> Channel
-> User
-> Command FullContext
-> Text
-> Text
-> FullContext
FullContext Message
msg Maybe Guild
guild Maybe Member
member Channel
channel User
usr Command FullContext
command Text
prefix Text
unparsed
data LightContext = LightContext
{
LightContext -> Message
message :: Message
,
LightContext -> Maybe (Snowflake Guild)
guildID :: Maybe (Snowflake Guild)
,
LightContext -> Snowflake Channel
channelID :: Snowflake Channel
,
LightContext -> User
user :: User
,
LightContext -> Maybe Member
member :: Maybe Member
,
LightContext -> Command LightContext
command :: Command LightContext
,
LightContext -> Text
prefix :: T.Text
,
LightContext -> Text
unparsedParams :: T.Text
}
deriving (Int -> LightContext -> ShowS
[LightContext] -> ShowS
LightContext -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LightContext] -> ShowS
$cshowList :: [LightContext] -> ShowS
show :: LightContext -> String
$cshow :: LightContext -> String
showsPrec :: Int -> LightContext -> ShowS
$cshowsPrec :: Int -> LightContext -> ShowS
Show)
deriving (Int -> LightContext -> Builder
Int -> LightContext -> Text
Int -> LightContext -> Text
[LightContext] -> Builder
[LightContext] -> Text
[LightContext] -> Text
LightContext -> Builder
LightContext -> Text
LightContext -> Text
forall a.
(Int -> a -> Builder)
-> (a -> Builder)
-> ([a] -> Builder)
-> (Int -> a -> Text)
-> (a -> Text)
-> ([a] -> Text)
-> (Int -> a -> Text)
-> (a -> Text)
-> ([a] -> Text)
-> TextShow a
showtlList :: [LightContext] -> Text
$cshowtlList :: [LightContext] -> Text
showtl :: LightContext -> Text
$cshowtl :: LightContext -> Text
showtlPrec :: Int -> LightContext -> Text
$cshowtlPrec :: Int -> LightContext -> Text
showtList :: [LightContext] -> Text
$cshowtList :: [LightContext] -> Text
showt :: LightContext -> Text
$cshowt :: LightContext -> Text
showtPrec :: Int -> LightContext -> Text
$cshowtPrec :: Int -> LightContext -> Text
showbList :: [LightContext] -> Builder
$cshowbList :: [LightContext] -> Builder
showb :: LightContext -> Builder
$cshowb :: LightContext -> Builder
showbPrec :: Int -> LightContext -> Builder
$cshowbPrec :: Int -> LightContext -> Builder
TextShow.TextShow) via TextShow.FromStringShow LightContext
deriving (HasID Channel) via HasIDField "channelID" LightContext
deriving (HasID Message) via HasIDField "message" LightContext
deriving (HasID User) via HasIDField "user" LightContext
$(makeFieldLabelsNoPrefix ''LightContext)
instance CC.CommandContext IO LightContext () where
ctxPrefix :: LightContext -> Text
ctxPrefix = (forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "prefix" a => a
#prefix)
ctxCommand :: LightContext -> Command LightContext
ctxCommand = (forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "command" a => a
#command)
ctxUnparsedParams :: LightContext -> Text
ctxUnparsedParams = (forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "unparsedParams" a => a
#unparsedParams)
instance CalamityCommandContext LightContext where
ctxChannelID :: LightContext -> Snowflake Channel
ctxChannelID = (forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "channelID" a => a
#channelID)
ctxGuildID :: LightContext -> Maybe (Snowflake Guild)
ctxGuildID = (forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "guildID" a => a
#guildID)
ctxUserID :: LightContext -> Snowflake User
ctxUserID = (forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "user" a => a
#user forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall a. IsLabel "id" a => a
#id)
ctxMessage :: LightContext -> Message
ctxMessage = (forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "message" a => a
#message)
instance Tellable LightContext where
getChannel :: forall (r :: EffectRow).
(BotC r, Member (Error RestError) r) =>
LightContext -> Sem r (Snowflake Channel)
getChannel = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. CalamityCommandContext c => c -> Snowflake Channel
ctxChannelID
useLightContext :: P.Sem (CC.ConstructContext (Message, User, Maybe Member) LightContext IO () ': r) a -> P.Sem r a
useLightContext :: forall (r :: EffectRow) a.
Sem
(ConstructContext (Message, User, Maybe Member) LightContext IO ()
: r)
a
-> Sem r a
useLightContext =
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
P.interpret
( \case
CC.ConstructContext (Text
pre, Command LightContext
cmd, Text
up) (Message
msg, User
usr, Maybe Member
mem) ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Message
-> Maybe (Snowflake Guild)
-> Snowflake Channel
-> User
-> Maybe Member
-> Command LightContext
-> Text
-> Text
-> LightContext
LightContext Message
msg (Message
msg forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "guildID" a => a
#guildID) (Message
msg forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "channelID" a => a
#channelID) User
usr Maybe Member
mem Command LightContext
cmd Text
pre Text
up
)