{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE RecursiveDo #-}
module Calamity.Commands.Utils (
addCommands,
useConstantPrefix,
CmdInvokeFailReason (..),
CtxCommandError (..),
CommandNotFound (..),
CommandInvoked (..),
) where
import Calamity.Client.Client
import Calamity.Client.Types
import CalamityCommands.CommandUtils
import qualified CalamityCommands.Error as CC
import Calamity.Commands.Dsl
import Calamity.Commands.Types
import Calamity.Metrics.Eff
import Calamity.Types.Model.Channel
import qualified CalamityCommands.Utils as CC
import Control.Monad
import qualified Data.Text as S
import qualified Data.Text.Lazy as L
import GHC.Generics (Generic)
import qualified Polysemy as P
import qualified CalamityCommands.Context as CC
import qualified CalamityCommands.ParsePrefix as CC
import Data.Typeable
data CmdInvokeFailReason c
= NoContext
| NotFound [L.Text]
| CommandInvokeError c CC.CommandError
data CtxCommandError c = CtxCommandError
{ CtxCommandError c -> c
ctx :: 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
showList :: [CtxCommandError c] -> ShowS
$cshowList :: forall c. Show c => [CtxCommandError c] -> ShowS
show :: CtxCommandError c -> String
$cshow :: forall c. Show c => CtxCommandError c -> String
showsPrec :: Int -> CtxCommandError c -> ShowS
$cshowsPrec :: forall c. Show c => Int -> CtxCommandError c -> ShowS
Show, (forall x. CtxCommandError c -> Rep (CtxCommandError c) x)
-> (forall x. Rep (CtxCommandError c) x -> CtxCommandError c)
-> Generic (CtxCommandError c)
forall x. Rep (CtxCommandError c) x -> CtxCommandError c
forall x. CtxCommandError c -> Rep (CtxCommandError c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (CtxCommandError c) x -> CtxCommandError c
forall c x. CtxCommandError c -> Rep (CtxCommandError c) x
$cto :: forall c x. Rep (CtxCommandError c) x -> CtxCommandError c
$cfrom :: forall c x. CtxCommandError c -> Rep (CtxCommandError c) x
Generic)
data CommandNotFound = CommandNotFound
{ CommandNotFound -> Message
msg :: Message
,
CommandNotFound -> [Text]
path :: [L.Text]
}
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
showList :: [CommandNotFound] -> ShowS
$cshowList :: [CommandNotFound] -> ShowS
show :: CommandNotFound -> String
$cshow :: CommandNotFound -> String
showsPrec :: Int -> CommandNotFound -> ShowS
$cshowsPrec :: Int -> CommandNotFound -> ShowS
Show, (forall x. CommandNotFound -> Rep CommandNotFound x)
-> (forall x. Rep CommandNotFound x -> CommandNotFound)
-> Generic CommandNotFound
forall x. Rep CommandNotFound x -> CommandNotFound
forall x. CommandNotFound -> Rep CommandNotFound x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CommandNotFound x -> CommandNotFound
$cfrom :: forall x. CommandNotFound -> Rep CommandNotFound x
Generic)
newtype CommandInvoked c = CommandInvoked
{ 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
showList :: [CommandInvoked c] -> ShowS
$cshowList :: forall c. Show c => [CommandInvoked c] -> ShowS
show :: CommandInvoked c -> String
$cshow :: forall c. Show c => CommandInvoked c -> String
showsPrec :: Int -> CommandInvoked c -> ShowS
$cshowsPrec :: forall c. Show c => Int -> CommandInvoked c -> ShowS
Show, (forall x. CommandInvoked c -> Rep (CommandInvoked c) x)
-> (forall x. Rep (CommandInvoked c) x -> CommandInvoked c)
-> Generic (CommandInvoked c)
forall x. Rep (CommandInvoked c) x -> CommandInvoked c
forall x. CommandInvoked c -> Rep (CommandInvoked c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (CommandInvoked c) x -> CommandInvoked c
forall c x. CommandInvoked c -> Rep (CommandInvoked c) x
$cto :: forall c x. Rep (CommandInvoked c) x -> CommandInvoked c
$cfrom :: forall c x. CommandInvoked c -> Rep (CommandInvoked c) x
Generic)
useConstantPrefix :: L.Text -> P.Sem (CC.ParsePrefix Message ': r) a -> P.Sem r a
useConstantPrefix :: Text -> Sem (ParsePrefix Message : r) a -> Sem r a
useConstantPrefix Text
pre = (forall x (rInitial :: EffectRow).
ParsePrefix Message (Sem rInitial) x -> Sem r x)
-> Sem (ParsePrefix Message : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall x (rInitial :: EffectRow). e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
P.interpret (\case
CC.ParsePrefix Message { content } -> Maybe (Text, Text) -> Sem r (Maybe (Text, Text))
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
L.stripPrefix Text
pre Text
content))
addCommands :: (BotC r, Typeable c, CommandContext c, P.Members [CC.ParsePrefix Message, CC.ConstructContext Message c IO ()] r)
=> P.Sem (DSLState c r) a -> P.Sem r (P.Sem r (), CommandHandler c, a)
addCommands :: 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 :: EffectRow) 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 (r :: EffectRow).
(BotC r, ReactConstraints 'MessageCreateEvt) =>
(EHType 'MessageCreateEvt -> Sem r ()) -> Sem r (Sem r ())
forall (s :: EventType) (r :: EffectRow).
(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
$ \EHType 'MessageCreateEvt
msg -> do
Message -> Sem r (Maybe (Text, Text))
forall msg (r :: EffectRow).
MemberWithError (ParsePrefix msg) r =>
msg -> Sem r (Maybe (Text, Text))
CC.parsePrefix Message
EHType 'MessageCreateEvt
msg Sem r (Maybe (Text, Text))
-> (Maybe (Text, Text) -> Sem r ()) -> Sem r ()
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
-> Text
-> Text
-> Sem r (Either (CmdInvokeFailReason c) (c, ()))
forall (m :: * -> *) msg c a (r :: EffectRow).
(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
EHType 'MessageCreateEvt
msg Text
prefix Text
cmd
case Either (CmdInvokeFailReason c) (c, ())
r of
Left (CC.CommandInvokeError c
ctx CommandError
e) -> CalamityEvent -> Sem r ()
forall (r :: EffectRow). 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 :: EffectRow). 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 -> [Text] -> CommandNotFound
CommandNotFound Message
EHType 'MessageCreateEvt
msg [Text]
path
Left CmdInvokeFailReason c
CC.NoContext -> () -> Sem r ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Right (c
ctx, ()) -> do
Counter
cmdInvoke <- Text -> [(Text, Text)] -> Sem r Counter
forall (r :: EffectRow).
MemberWithError MetricEff r =>
Text -> [(Text, Text)] -> Sem r Counter
registerCounter Text
"commands_invoked" [(Text
"name", [Text] -> Text
S.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 :: EffectRow).
MemberWithError MetricEff r =>
Int -> Counter -> Sem r Int
addCounter Int
1 Counter
cmdInvoke
CalamityEvent -> Sem r ()
forall (r :: EffectRow). 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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Sem r (), CommandHandler c, a)
-> Sem r (Sem r (), CommandHandler c, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sem r ()
remove, CommandHandler c
handler, a
res)