{-# LANGUAGE TemplateHaskell #-}

-- | Command invokation context
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
  -- | The id of the channel that invoked this command
  ctxChannelID :: c -> Snowflake Channel

  -- | The id of the guild the command was invoked in, if in a guild
  ctxGuildID :: c -> Maybe (Snowflake Guild)

  -- | The id of the user that invoked this command
  ctxUserID :: c -> Snowflake User

  -- | The message that triggered this command
  ctxMessage :: c -> Message

-- | Invokation context for commands
data FullContext = FullContext
  { -- | The message that the command was invoked from
    FullContext -> Message
message :: Message
  , -- | If the command was sent in a guild, this will be present
    FullContext -> Maybe Guild
guild :: Maybe Guild
  , -- | The member that invoked the command, if in a guild
    --
    -- Note: If discord sent a member with the message, this is used; otherwise
    -- we try to fetch the member from the cache.
    FullContext -> Maybe Member
member :: Maybe Member
  , -- | The channel the command was invoked from
    FullContext -> Channel
channel :: Channel
  , -- | The user that invoked the command
    FullContext -> User
user :: User
  , -- | The command that was invoked
    FullContext -> Command FullContext
command :: Command FullContext
  , -- | The prefix that was used to invoke the command
    FullContext -> Text
prefix :: T.Text
  , -- | The message remaining after consuming the prefix
    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

-- | A lightweight context that doesn't need any cache information
data LightContext = LightContext
  { -- | The message that the command was invoked from
    LightContext -> Message
message :: Message
  , -- | If the command was sent in a guild, this will be present
    LightContext -> Maybe (Snowflake Guild)
guildID :: Maybe (Snowflake Guild)
  , -- | The channel the command was invoked from
    LightContext -> Snowflake Channel
channelID :: Snowflake Channel
  , -- | The user that invoked the command
    LightContext -> User
user :: User
  , -- | The member that triggered the command.
    --
    -- Note: Only sent if discord sent the member object with the message.
    LightContext -> Maybe Member
member :: Maybe Member
  , -- | The command that was invoked
    LightContext -> Command LightContext
command :: Command LightContext
  , -- | The prefix that was used to invoke the command
    LightContext -> Text
prefix :: T.Text
  , -- | The message remaining after consuming the prefix
    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
    )