{-# LANGUAGE TemplateHaskell #-}

-- | Command handler utilities
module Calamity.Commands.Utils (
  addCommands,
  useConstantPrefix,
  CmdInvokeFailReason (..),
  CtxCommandError (..),
  CommandNotFound (..),
  CommandInvoked (..),
) where

import Calamity.Client.Client
import Calamity.Client.Types
import Calamity.Commands.Dsl
import Calamity.Commands.Types
import Calamity.Metrics.Eff
import Calamity.Types.Model.Channel
import Calamity.Types.Model.Guild.Member (Member)
import Calamity.Types.Model.User (User)
import CalamityCommands.CommandUtils
import CalamityCommands.Context qualified as CC
import CalamityCommands.Error qualified as CC
import CalamityCommands.ParsePrefix qualified as CC
import CalamityCommands.Utils qualified as CC
import Control.Monad
import Data.Text qualified as T
import Data.Typeable
import Optics.TH (makeFieldLabelsNoPrefix)
import Polysemy qualified as P

data CmdInvokeFailReason c
  = NoContext
  | NotFound [T.Text]
  | CommandInvokeError c CC.CommandError

data CtxCommandError c = CtxCommandError
  { forall c. CtxCommandError c -> c
ctx :: c
  , forall c. CtxCommandError c -> CommandError
err :: CC.CommandError
  }
  deriving (Int -> CtxCommandError c -> ShowS
[CtxCommandError c] -> ShowS
CtxCommandError c -> String
(Int -> CtxCommandError c -> ShowS)
-> (CtxCommandError c -> String)
-> ([CtxCommandError c] -> ShowS)
-> Show (CtxCommandError c)
forall c. Show c => Int -> CtxCommandError c -> ShowS
forall c. Show c => [CtxCommandError c] -> ShowS
forall c. Show c => CtxCommandError c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall c. Show c => Int -> CtxCommandError c -> ShowS
showsPrec :: Int -> CtxCommandError c -> ShowS
$cshow :: forall c. Show c => CtxCommandError c -> String
show :: CtxCommandError c -> String
$cshowList :: forall c. Show c => [CtxCommandError c] -> ShowS
showList :: [CtxCommandError c] -> ShowS
Show)

data CommandNotFound = CommandNotFound
  { CommandNotFound -> Message
msg :: Message
  , CommandNotFound -> User
user :: User
  , CommandNotFound -> Maybe Member
member :: Maybe Member
  , CommandNotFound -> [Text]
path :: [T.Text]
  -- ^ The groups that were successfully parsed
  }
  deriving (Int -> CommandNotFound -> ShowS
[CommandNotFound] -> ShowS
CommandNotFound -> String
(Int -> CommandNotFound -> ShowS)
-> (CommandNotFound -> String)
-> ([CommandNotFound] -> ShowS)
-> Show CommandNotFound
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CommandNotFound -> ShowS
showsPrec :: Int -> CommandNotFound -> ShowS
$cshow :: CommandNotFound -> String
show :: CommandNotFound -> String
$cshowList :: [CommandNotFound] -> ShowS
showList :: [CommandNotFound] -> ShowS
Show)

newtype CommandInvoked c = CommandInvoked
  { forall c. CommandInvoked c -> c
ctx :: c
  }
  deriving stock (Int -> CommandInvoked c -> ShowS
[CommandInvoked c] -> ShowS
CommandInvoked c -> String
(Int -> CommandInvoked c -> ShowS)
-> (CommandInvoked c -> String)
-> ([CommandInvoked c] -> ShowS)
-> Show (CommandInvoked c)
forall c. Show c => Int -> CommandInvoked c -> ShowS
forall c. Show c => [CommandInvoked c] -> ShowS
forall c. Show c => CommandInvoked c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall c. Show c => Int -> CommandInvoked c -> ShowS
showsPrec :: Int -> CommandInvoked c -> ShowS
$cshow :: forall c. Show c => CommandInvoked c -> String
show :: CommandInvoked c -> String
$cshowList :: forall c. Show c => [CommandInvoked c] -> ShowS
showList :: [CommandInvoked c] -> ShowS
Show)

-- | A default interpretation for 'CC.ParsePrefix' that uses a single constant prefix.
useConstantPrefix :: T.Text -> P.Sem (CC.ParsePrefix Message ': r) a -> P.Sem r a
useConstantPrefix :: forall (r :: [(* -> *) -> * -> *]) a.
Text -> Sem (ParsePrefix Message : r) a -> Sem r a
useConstantPrefix Text
pre =
  (forall (rInitial :: [(* -> *) -> * -> *]) x.
 ParsePrefix Message (Sem rInitial) x -> Sem r x)
-> Sem (ParsePrefix Message : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall (rInitial :: [(* -> *) -> * -> *]) x.
 e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
P.interpret
    ( \case
        CC.ParsePrefix Message {Text
content :: Text
$sel:content:Message :: Message -> Text
content} -> x -> Sem r x
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Text
pre,) (Text -> (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe Text
T.stripPrefix Text
pre Text
content)
    )

{- | Construct commands and groups from a command DSL, then registers an event
 handler on the bot that manages running those commands.


 Returns an action to remove the event handler, and the 'CommandHandler' that was constructed.

 ==== Command Resolution

 To determine if a command was invoked, and if so which command was invoked, the following happens:

     1. 'CalamityCommands.ParsePrefix.parsePrefix' is invoked, if no prefix is found: stop here.

     2. The input is read a word at a time until a matching command is found,
        fire the \"command-not-found\" event if not.

     3. A 'Calamity.Commands.Context.Context' is built, and the command invoked.

 ==== Custom Events

 This will fire the following events:

     1. 'CtxCommandError'

         Fired when a command returns an error.

     2. 'CommandNotFound'

         Fired when a valid prefix is used, but the command is not found.

     3. 'CommandInvoked'

         Fired when a command is successfully invoked.
-}
addCommands ::
  (BotC r, Typeable c, CommandContext c, P.Members [CC.ParsePrefix Message, CC.ConstructContext (Message, User, Maybe Member) c IO ()] r) =>
  P.Sem (DSLState c r) a ->
  P.Sem r (P.Sem r (), CommandHandler c, a)
addCommands :: forall (r :: [(* -> *) -> * -> *]) c a.
(BotC r, Typeable c, CommandContext c,
 Members
   '[ParsePrefix Message,
     ConstructContext (Message, User, Maybe Member) c IO ()]
   r) =>
Sem (DSLState c r) a -> Sem r (Sem r (), CommandHandler c, a)
addCommands Sem (DSLState c r) a
m = do
  (CommandHandler c
handler, a
res) <- Sem (DSLState c r) a -> Sem r (CommandHandler c, a)
forall (r :: [(* -> *) -> * -> *]) c (m :: * -> *) a x.
(Monad m, MonadFix m, Member (Final m) r) =>
Sem (DSLState m c a r) x -> Sem r (CommandHandler m c a, x)
CC.buildCommands Sem (DSLState c r) a
m
  Sem r ()
remove <- forall (s :: EventType) (r :: [(* -> *) -> * -> *]).
(BotC r, ReactConstraints s) =>
(EHType s -> Sem r ()) -> Sem r (Sem r ())
react @'MessageCreateEvt ((EHType 'MessageCreateEvt -> Sem r ()) -> Sem r (Sem r ()))
-> (EHType 'MessageCreateEvt -> Sem r ()) -> Sem r (Sem r ())
forall a b. (a -> b) -> a -> b
$ \case
    (Message
msg, Just User
user, Maybe Member
member) -> do
      Message -> Sem r (Maybe (Text, Text))
forall msg (r :: [(* -> *) -> * -> *]).
Member (ParsePrefix msg) r =>
msg -> Sem r (Maybe (Text, Text))
CC.parsePrefix Message
msg Sem r (Maybe (Text, Text))
-> (Maybe (Text, Text) -> Sem r ()) -> Sem r ()
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just (Text
prefix, Text
cmd) -> do
          Either (CmdInvokeFailReason c) (c, ())
r <- CommandHandler c
-> (Message, User, Maybe Member)
-> Text
-> Text
-> Sem r (Either (CmdInvokeFailReason c) (c, ()))
forall (m :: * -> *) msg c a (r :: [(* -> *) -> * -> *]).
(Monad m, Members '[ConstructContext msg c m a, Embed m] r,
 CommandContext m c a) =>
CommandHandler m c a
-> msg
-> Text
-> Text
-> Sem r (Either (CmdInvokeFailReason c) (c, a))
CC.handleCommands CommandHandler c
handler (Message
msg, User
user, Maybe Member
member) Text
prefix Text
cmd
          case Either (CmdInvokeFailReason c) (c, ())
r of
            Left (CC.CommandInvokeError c
ctx CommandError
e) -> CalamityEvent -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
BotC r =>
CalamityEvent -> Sem r ()
fire (CalamityEvent -> Sem r ())
-> (CtxCommandError c -> CalamityEvent)
-> CtxCommandError c
-> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CtxCommandError c -> CalamityEvent
forall a. Typeable a => a -> CalamityEvent
customEvt (CtxCommandError c -> Sem r ()) -> CtxCommandError c -> Sem r ()
forall a b. (a -> b) -> a -> b
$ c -> CommandError -> CtxCommandError c
forall c. c -> CommandError -> CtxCommandError c
CtxCommandError c
ctx CommandError
e
            Left (CC.NotFound [Text]
path) -> CalamityEvent -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
BotC r =>
CalamityEvent -> Sem r ()
fire (CalamityEvent -> Sem r ())
-> (CommandNotFound -> CalamityEvent)
-> CommandNotFound
-> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandNotFound -> CalamityEvent
forall a. Typeable a => a -> CalamityEvent
customEvt (CommandNotFound -> Sem r ()) -> CommandNotFound -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Message -> User -> Maybe Member -> [Text] -> CommandNotFound
CommandNotFound Message
msg User
user Maybe Member
member [Text]
path
            Left CmdInvokeFailReason c
CC.NoContext -> () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- ignore if context couldn't be built
            Right (c
ctx, ()) -> do
              Counter
cmdInvoke <- Text -> [(Text, Text)] -> Sem r Counter
forall (r :: [(* -> *) -> * -> *]).
Member MetricEff r =>
Text -> [(Text, Text)] -> Sem r Counter
registerCounter Text
"commands_invoked" [(Text
"name", [Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Command IO c () -> [Text]
forall (m :: * -> *) c a. Command m c a -> [Text]
commandPath (c -> Command IO c ()
forall (m :: * -> *) c a.
CommandContext m c a =>
c -> Command m c a
CC.ctxCommand c
ctx))]
              Sem r Int -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r Int -> Sem r ()) -> Sem r Int -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Int -> Counter -> Sem r Int
forall (r :: [(* -> *) -> * -> *]).
Member MetricEff r =>
Int -> Counter -> Sem r Int
addCounter Int
1 Counter
cmdInvoke
              CalamityEvent -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
BotC r =>
CalamityEvent -> Sem r ()
fire (CalamityEvent -> Sem r ())
-> (CommandInvoked c -> CalamityEvent)
-> CommandInvoked c
-> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandInvoked c -> CalamityEvent
forall a. Typeable a => a -> CalamityEvent
customEvt (CommandInvoked c -> Sem r ()) -> CommandInvoked c -> Sem r ()
forall a b. (a -> b) -> a -> b
$ c -> CommandInvoked c
forall c. c -> CommandInvoked c
CommandInvoked c
ctx
        Maybe (Text, Text)
Nothing -> () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    EHType 'MessageCreateEvt
_ -> () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  (Sem r (), CommandHandler c, a)
-> Sem r (Sem r (), CommandHandler c, a)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sem r ()
remove, CommandHandler c
handler, a
res)

$(makeFieldLabelsNoPrefix ''CmdInvokeFailReason)
$(makeFieldLabelsNoPrefix ''CtxCommandError)
$(makeFieldLabelsNoPrefix ''CommandNotFound)
$(makeFieldLabelsNoPrefix ''CommandInvoked)