{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances, FunctionalDependencies, UndecidableInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Command.Command
(
Command
, command
, runCommand
, runCommands
, runHelp
, parsecCommand
, regexCommand
, help
, alias
, onError
, defaultErrorHandler
, requires
, CommandError(..)
, ParsableArgument
, RemainingText(..)
, module Discord.Internal.Monad
, MonadIO(..)
) where
import Control.Applicative ( Alternative(..)
)
import Control.Exception.Safe ( catch
, throwM
, MonadCatch
, MonadThrow
, Exception
, SomeException
)
import Control.Monad.IO.Class ( MonadIO )
import Control.Monad ( void
, guard
, unless
)
import Data.Maybe ( catMaybes )
import qualified Data.Text as T
import Text.Parsec.Combinator
import Text.Parsec.Error ( errorMessages
, showErrorMessages
)
import qualified Text.Parsec.Text as T
import Text.Parsec ( parse
, eof
, ParseError
, space
, anyChar
, string
, getInput
)
import Text.Regex.TDFA ( (=~) )
import UnliftIO ( liftIO )
import Discord.Internal.Monad
import Discord.Types
import Discord
import Command.Error ( CommandError(..) )
import Command.Parser ( ParsableArgument(..)
, RemainingText(..)
, manyTill1
, endOrSpaces
)
import Owoifier ( owoify )
data Command m = Command
{ Command m -> Text
commandName :: T.Text
, Command m -> Text
commandPrefix :: T.Text
, Command m -> [Text]
commandAliases :: [T.Text]
, Command m -> Message -> Command m -> Maybe [Text]
commandInitialMatch :: Message -> Command m -> Maybe [T.Text]
, Command m -> Message -> [Text] -> m ()
commandApplier :: Message -> [T.Text] -> m ()
, Command m -> Message -> CommandError -> m ()
commandErrorHandler :: Message -> CommandError -> m ()
, Command m -> Text
commandHelp :: T.Text
, Command m -> [Message -> m (Maybe Text)]
commandRequires :: [Message -> m (Maybe T.Text)]
}
command
:: (CommandHandlerType m h , MonadDiscord m)
=> T.Text
-> h
-> Command m
command :: Text -> h -> Command m
command Text
name h
commandHandler = Command :: forall (m :: * -> *).
Text
-> Text
-> [Text]
-> (Message -> Command m -> Maybe [Text])
-> (Message -> [Text] -> m ())
-> (Message -> CommandError -> m ())
-> Text
-> [Message -> m (Maybe Text)]
-> Command m
Command
{ commandName :: Text
commandName = Text
name
, commandPrefix :: Text
commandPrefix = Text
":"
, commandAliases :: [Text]
commandAliases = []
, commandInitialMatch :: Message -> Command m -> Maybe [Text]
commandInitialMatch = \Message
msg Command m
cmd ->
case Parsec Text () Text -> SourceName -> Text -> Either ParseError Text
forall s t a.
Stream s Identity t =>
Parsec s () a -> SourceName -> s -> Either ParseError a
parse (Command m -> Parsec Text () Text
forall (m :: * -> *). Command m -> Parsec Text () Text
parseCommandName Command m
cmd) SourceName
"" (Message -> Text
messageText Message
msg) of
Left ParseError
e -> Maybe [Text]
forall a. Maybe a
Nothing
Right Text
args -> [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text
args]
, commandApplier :: Message -> [Text] -> m ()
commandApplier = \Message
x [Text]
y -> h -> Message -> Text -> m ()
forall (m :: * -> *) h.
CommandHandlerType m h =>
h -> Message -> Text -> m ()
applyArgs h
commandHandler Message
x ([Text] -> Text
forall a. [a] -> a
head [Text]
y)
, commandErrorHandler :: Message -> CommandError -> m ()
commandErrorHandler = Message -> CommandError -> m ()
forall (m :: * -> *).
MonadDiscord m =>
Message -> CommandError -> m ()
defaultErrorHandler
, commandHelp :: Text
commandHelp = Text
"Help not available."
, commandRequires :: [Message -> m (Maybe Text)]
commandRequires = []
}
onError
:: (Message -> CommandError -> m ())
-> Command m
-> Command m
onError :: (Message -> CommandError -> m ()) -> Command m -> Command m
onError Message -> CommandError -> m ()
errorHandler Command m
cmd = Command m
cmd
{ commandErrorHandler :: Message -> CommandError -> m ()
commandErrorHandler = Message -> CommandError -> m ()
errorHandler
}
prefix
:: T.Text
-> Command m
-> Command m
prefix :: Text -> Command m -> Command m
prefix Text
newPrefix Command m
cmd = Command m
cmd
{ commandPrefix :: Text
commandPrefix = Text
newPrefix
}
requires :: (Message -> m (Maybe T.Text)) -> Command m -> Command m
requires :: (Message -> m (Maybe Text)) -> Command m -> Command m
requires Message -> m (Maybe Text)
requirement Command m
cmd = Command m
cmd
{ commandRequires :: [Message -> m (Maybe Text)]
commandRequires = Message -> m (Maybe Text)
requirement (Message -> m (Maybe Text))
-> [Message -> m (Maybe Text)] -> [Message -> m (Maybe Text)]
forall a. a -> [a] -> [a]
: Command m -> [Message -> m (Maybe Text)]
forall (m :: * -> *). Command m -> [Message -> m (Maybe Text)]
commandRequires Command m
cmd
}
help :: T.Text -> Command m -> Command m
help :: Text -> Command m -> Command m
help Text
newHelp Command m
cmd = Command m
cmd
{ commandHelp :: Text
commandHelp = Text
newHelp
}
alias :: T.Text -> Command m -> Command m
alias :: Text -> Command m -> Command m
alias Text
newAlias Command m
cmd = Command m
cmd
{ commandAliases :: [Text]
commandAliases = Text
newAlias Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Command m -> [Text]
forall (m :: * -> *). Command m -> [Text]
commandAliases Command m
cmd
}
parsecCommand
:: (MonadDiscord m)
=> T.Parser String
-> (Message -> String -> m ())
-> Command m
parsecCommand :: Parser SourceName -> (Message -> SourceName -> m ()) -> Command m
parsecCommand Parser SourceName
parserFunc Message -> SourceName -> m ()
commandHandler = Command :: forall (m :: * -> *).
Text
-> Text
-> [Text]
-> (Message -> Command m -> Maybe [Text])
-> (Message -> [Text] -> m ())
-> (Message -> CommandError -> m ())
-> Text
-> [Message -> m (Maybe Text)]
-> Command m
Command
{ commandName :: Text
commandName = Text
"<custom parser>"
, commandPrefix :: Text
commandPrefix = Text
""
, commandAliases :: [Text]
commandAliases = []
, commandInitialMatch :: Message -> Command m -> Maybe [Text]
commandInitialMatch = \Message
msg Command m
cmd ->
let
parser :: Parser SourceName
parser = SourceName -> Parser SourceName
forall s (m :: * -> *) u.
Stream s m Char =>
SourceName -> ParsecT s u m SourceName
string (Text -> SourceName
T.unpack (Text -> SourceName) -> Text -> SourceName
forall a b. (a -> b) -> a -> b
$ Command m -> Text
forall (m :: * -> *). Command m -> Text
commandPrefix Command m
cmd) Parser SourceName -> Parser SourceName -> Parser SourceName
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser SourceName
parserFunc
in
case Parser SourceName
-> SourceName -> Text -> Either ParseError SourceName
forall s t a.
Stream s Identity t =>
Parsec s () a -> SourceName -> s -> Either ParseError a
parse Parser SourceName
parser SourceName
"" (Message -> Text
messageText Message
msg) of
Left ParseError
e -> Maybe [Text]
forall a. Maybe a
Nothing
Right SourceName
result -> [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [SourceName -> Text
T.pack SourceName
result]
, commandApplier :: Message -> [Text] -> m ()
commandApplier = \Message
x [Text]
y -> Message -> SourceName -> m ()
commandHandler Message
x (Text -> SourceName
T.unpack (Text -> SourceName) -> Text -> SourceName
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. [a] -> a
head [Text]
y)
, commandErrorHandler :: Message -> CommandError -> m ()
commandErrorHandler = Message -> CommandError -> m ()
forall (m :: * -> *).
MonadDiscord m =>
Message -> CommandError -> m ()
defaultErrorHandler
, commandHelp :: Text
commandHelp = Text
"Help not available."
, commandRequires :: [Message -> m (Maybe Text)]
commandRequires = []
}
regexCommand
:: (MonadDiscord m)
=> T.Text
-> (Message -> [T.Text] -> m ())
-> Command m
regexCommand :: Text -> (Message -> [Text] -> m ()) -> Command m
regexCommand Text
regex Message -> [Text] -> m ()
commandHandler = Command :: forall (m :: * -> *).
Text
-> Text
-> [Text]
-> (Message -> Command m -> Maybe [Text])
-> (Message -> [Text] -> m ())
-> (Message -> CommandError -> m ())
-> Text
-> [Message -> m (Maybe Text)]
-> Command m
Command
{ commandName :: Text
commandName = Text
"<regex>"
, commandPrefix :: Text
commandPrefix = Text
""
, commandAliases :: [Text]
commandAliases = []
, commandInitialMatch :: Message -> Command m -> Maybe [Text]
commandInitialMatch = \Message
msg Command m
cmd ->
case Message -> Text
messageText Message
msg Text -> Text -> [[Text]]
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
=~ Text
regex :: [[T.Text]] of
[] -> Maybe [Text]
forall a. Maybe a
Nothing
[[Text]]
xs -> [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just ([Text] -> Maybe [Text]) -> [Text] -> Maybe [Text]
forall a b. (a -> b) -> a -> b
$ ([Text] -> [Text]) -> [[Text]] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Text] -> [Text]
forall a. [a] -> [a]
tail [[Text]]
xs
, commandApplier :: Message -> [Text] -> m ()
commandApplier = Message -> [Text] -> m ()
commandHandler
, commandErrorHandler :: Message -> CommandError -> m ()
commandErrorHandler = Message -> CommandError -> m ()
forall (m :: * -> *).
MonadDiscord m =>
Message -> CommandError -> m ()
defaultErrorHandler
, commandHelp :: Text
commandHelp = Text
"Help not available."
, commandRequires :: [Message -> m (Maybe Text)]
commandRequires = []
}
runCommand
:: forall m.
(MonadDiscord m)
=> Command m
-> Message
-> m ()
runCommand :: Command m -> Message -> m ()
runCommand cmd :: Command m
cmd@Command{ Message -> Command m -> Maybe [Text]
commandInitialMatch :: Message -> Command m -> Maybe [Text]
commandInitialMatch :: forall (m :: * -> *).
Command m -> Message -> Command m -> Maybe [Text]
commandInitialMatch, Message -> [Text] -> m ()
commandApplier :: Message -> [Text] -> m ()
commandApplier :: forall (m :: * -> *). Command m -> Message -> [Text] -> m ()
commandApplier, Message -> CommandError -> m ()
commandErrorHandler :: Message -> CommandError -> m ()
commandErrorHandler :: forall (m :: * -> *). Command m -> Message -> CommandError -> m ()
commandErrorHandler, [Message -> m (Maybe Text)]
commandRequires :: [Message -> m (Maybe Text)]
commandRequires :: forall (m :: * -> *). Command m -> [Message -> m (Maybe Text)]
commandRequires } Message
msg =
case Message -> Command m -> Maybe [Text]
commandInitialMatch Message
msg Command m
cmd of
Maybe [Text]
Nothing -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just [Text]
results -> do
[Maybe Text]
checks <- ((Message -> m (Maybe Text)) -> m (Maybe Text))
-> [Message -> m (Maybe Text)] -> m [Maybe Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Message -> m (Maybe Text)) -> Message -> m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Message
msg) [Message -> m (Maybe Text)]
commandRequires
let failedChecks :: [Text]
failedChecks = [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Text]
checks
if [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
failedChecks then
Message -> [Text] -> m ()
commandApplier Message
msg [Text]
results
m () -> (CommandError -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` CommandError -> m ()
basicErrorCatcher
m () -> (SomeException -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` SomeException -> m ()
allErrorCatcher
else
CommandError -> m ()
basicErrorCatcher (Text -> CommandError
RequirementError (Text -> CommandError) -> Text -> CommandError
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. [a] -> a
head [Text]
failedChecks)
where
basicErrorCatcher :: CommandError -> m ()
basicErrorCatcher :: CommandError -> m ()
basicErrorCatcher = Message -> CommandError -> m ()
commandErrorHandler Message
msg
allErrorCatcher :: SomeException -> m ()
allErrorCatcher :: SomeException -> m ()
allErrorCatcher = Message -> CommandError -> m ()
commandErrorHandler Message
msg (CommandError -> m ())
-> (SomeException -> CommandError) -> SomeException -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> CommandError
HaskellError
runCommands
:: (MonadDiscord m, Alternative m)
=> [Command m]
-> Message
-> m ()
runCommands :: [Command m] -> Message -> m ()
runCommands = (Message -> [Command m] -> m ()) -> [Command m] -> Message -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Command m -> m ()) -> [Command m] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Command m -> m ()) -> [Command m] -> m ())
-> (Message -> Command m -> m ()) -> Message -> [Command m] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Command m -> Message -> m ()) -> Message -> Command m -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Command m -> Message -> m ()
forall (m :: * -> *).
MonadDiscord m =>
Command m -> Message -> m ()
runCommand)
runHelp
:: (MonadDiscord m)
=> T.Text
-> [Command m]
-> Message
-> m ()
runHelp :: Text -> [Command m] -> Message -> m ()
runHelp Text
name [Command m]
cmds
= Command m -> Message -> m ()
forall (m :: * -> *).
MonadDiscord m =>
Command m -> Message -> m ()
runCommand
(Command m -> Message -> m ())
-> ((Message -> m ()) -> Command m)
-> (Message -> m ())
-> Message
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> (Message -> m ()) -> Command m
forall (m :: * -> *) h.
(CommandHandlerType m h, MonadDiscord m) =>
Text -> h -> Command m
command Text
name ((Message -> m ()) -> Message -> m ())
-> (Message -> m ()) -> Message -> m ()
forall a b. (a -> b) -> a -> b
$ \Message
msg -> do
Channel
chan <- UserId -> m Channel
forall (m :: * -> *). MonadDiscord m => UserId -> m Channel
createDM (User -> UserId
userId (User -> UserId) -> User -> UserId
forall a b. (a -> b) -> a -> b
$ Message -> User
messageAuthor Message
msg)
m Message -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Message -> m ()) -> m Message -> m ()
forall a b. (a -> b) -> a -> b
$ UserId -> Text -> m Message
forall (m :: * -> *). MonadDiscord m => UserId -> Text -> m Message
createMessage (Channel -> UserId
channelId Channel
chan) (Text -> m Message) -> Text -> m Message
forall a b. (a -> b) -> a -> b
$
Text
"```" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"\n" ((Command m -> Text) -> [Command m] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Command m -> Text
forall (m :: * -> *). Command m -> Text
createCommandHelp [Command m]
cmds) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"```"
where
createCommandHelp :: Command m -> T.Text
createCommandHelp :: Command m -> Text
createCommandHelp Command{ Text
commandPrefix :: Text
commandPrefix :: forall (m :: * -> *). Command m -> Text
commandPrefix, Text
commandName :: Text
commandName :: forall (m :: * -> *). Command m -> Text
commandName, Text
commandHelp :: Text
commandHelp :: forall (m :: * -> *). Command m -> Text
commandHelp } =
Text
"# " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
commandPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
commandName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
commandHelp
defaultErrorHandler
:: (MonadDiscord m)
=> Message
-> CommandError
-> m ()
defaultErrorHandler :: Message -> CommandError -> m ()
defaultErrorHandler Message
m CommandError
e =
case CommandError
e of
ArgumentParseError Text
x ->
Message -> Text -> m ()
forall (m :: * -> *). MonadDiscord m => Message -> Text -> m ()
respond Message
m Text
x
RequirementError Text
x ->
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"") (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Channel
chan <- UserId -> m Channel
forall (m :: * -> *). MonadDiscord m => UserId -> m Channel
createDM (User -> UserId
userId (User -> UserId) -> User -> UserId
forall a b. (a -> b) -> a -> b
$ Message -> User
messageAuthor Message
m)
m Message -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Message -> m ()) -> m Message -> m ()
forall a b. (a -> b) -> a -> b
$ UserId -> Text -> m Message
forall (m :: * -> *). MonadDiscord m => UserId -> Text -> m Message
createMessage (Channel -> UserId
channelId Channel
chan) Text
x
ProcessingError Text
x ->
Message -> Text -> m ()
forall (m :: * -> *). MonadDiscord m => Message -> Text -> m ()
respond Message
m Text
x
DiscordError RestCallErrorCode
x ->
Message -> Text -> m ()
forall (m :: * -> *). MonadDiscord m => Message -> Text -> m ()
respond Message
m (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ SourceName -> Text
T.pack (SourceName -> Text) -> SourceName -> Text
forall a b. (a -> b) -> a -> b
$ SourceName
"Discord request failed with a " SourceName -> SourceName -> SourceName
forall a. Semigroup a => a -> a -> a
<> RestCallErrorCode -> SourceName
forall a. Show a => a -> SourceName
show RestCallErrorCode
x
HaskellError SomeException
x ->
Message -> Text -> m ()
forall (m :: * -> *). MonadDiscord m => Message -> Text -> m ()
respond Message
m (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
owoify (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ SourceName -> Text
T.pack (SourceName -> Text) -> SourceName -> Text
forall a b. (a -> b) -> a -> b
$ SourceName
"Runtime error (contact OwenDev, this is a bug): " SourceName -> SourceName -> SourceName
forall a. Semigroup a => a -> a -> a
<> SomeException -> SourceName
forall a. Show a => a -> SourceName
show SomeException
x
parseCommandName :: Command m -> T.Parser T.Text
parseCommandName :: Command m -> Parsec Text () Text
parseCommandName Command m
cmd = do
SourceName -> Parser SourceName
forall s (m :: * -> *) u.
Stream s m Char =>
SourceName -> ParsecT s u m SourceName
string (Text -> SourceName
T.unpack (Text -> SourceName) -> Text -> SourceName
forall a b. (a -> b) -> a -> b
$ Command m -> Text
forall (m :: * -> *). Command m -> Text
commandPrefix Command m
cmd)
SourceName
cmdName <- ParsecT Text () Identity Char
-> ParsecT Text () Identity () -> Parser SourceName
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill1 ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT Text () Identity Char -> ParsecT Text () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Text () Identity Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space) ParsecT Text () Identity ()
-> ParsecT Text () Identity () -> ParsecT Text () Identity ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Text () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof)
Bool -> ParsecT Text () Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ParsecT Text () Identity ())
-> Bool -> ParsecT Text () Identity ()
forall a b. (a -> b) -> a -> b
$ SourceName -> Text
T.pack SourceName
cmdName Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Command m -> Text
forall (m :: * -> *). Command m -> Text
commandName Command m
cmd Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Command m -> [Text]
forall (m :: * -> *). Command m -> [Text]
commandAliases Command m
cmd)
(ParsecT Text () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof ParsecT Text () Identity ()
-> Parsec Text () Text -> Parsec Text () Text
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> Parsec Text () Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"") Parsec Text () Text -> Parsec Text () Text -> Parsec Text () Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do
ParsecT Text () Identity Char -> Parser SourceName
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space
SourceName
args <- ParsecT Text () Identity Char
-> ParsecT Text () Identity () -> Parser SourceName
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar ParsecT Text () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
Text -> Parsec Text () Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SourceName -> Text
T.pack SourceName
args)
class (MonadThrow m) => CommandHandlerType m h | h -> m where
applyArgs
:: h
-> Message
-> T.Text
-> m ()
instance (MonadThrow m) => CommandHandlerType m (m ()) where
applyArgs :: m () -> Message -> Text -> m ()
applyArgs m ()
handler Message
msg Text
input =
case ParsecT Text () Identity ()
-> SourceName -> Text -> Either ParseError ()
forall s t a.
Stream s Identity t =>
Parsec s () a -> SourceName -> s -> Either ParseError a
parse ParsecT Text () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof SourceName
"" Text
input of
Left ParseError
e -> CommandError -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (CommandError -> m ()) -> CommandError -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> CommandError
ArgumentParseError (Text -> CommandError) -> Text -> CommandError
forall a b. (a -> b) -> a -> b
$
Text
"Too many arguments! " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ParseError -> Text
showErrAsText ParseError
e
Right ()
_ -> m ()
handler
instance (MonadThrow m, ParsableArgument a, CommandHandlerType m b) => CommandHandlerType m (a -> b) where
applyArgs :: (a -> b) -> Message -> Text -> m ()
applyArgs a -> b
handler Message
msg Text
input = do
let p :: ParsecT Text () Identity (a, Text)
p = (,) (a -> Text -> (a, Text))
-> ParsecT Text () Identity a
-> ParsecT Text () Identity (Text -> (a, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Text () Identity a
forall a. ParsableArgument a => Parser a
parserForArg ParsecT Text () Identity a
-> ParsecT Text () Identity () -> ParsecT Text () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Text () Identity ()
endOrSpaces) ParsecT Text () Identity (Text -> (a, Text))
-> Parsec Text () Text -> ParsecT Text () Identity (a, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parsec Text () Text
forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
case ParsecT Text () Identity (a, Text)
-> SourceName -> Text -> Either ParseError (a, Text)
forall s t a.
Stream s Identity t =>
Parsec s () a -> SourceName -> s -> Either ParseError a
parse ParsecT Text () Identity (a, Text)
p SourceName
"arguments" Text
input of
Left ParseError
e -> CommandError -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (CommandError -> m ()) -> CommandError -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> CommandError
ArgumentParseError (Text -> CommandError) -> Text -> CommandError
forall a b. (a -> b) -> a -> b
$
Text
"Error while parsing argument. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ParseError -> Text
showErrAsText ParseError
e
Right (a
x, Text
remaining) -> b -> Message -> Text -> m ()
forall (m :: * -> *) h.
CommandHandlerType m h =>
h -> Message -> Text -> m ()
applyArgs (a -> b
handler a
x) Message
msg Text
remaining
instance {-# OVERLAPPING #-} (MonadThrow m, CommandHandlerType m b) => CommandHandlerType m (Message -> b) where
applyArgs :: (Message -> b) -> Message -> Text -> m ()
applyArgs Message -> b
handler Message
msg Text
input = b -> Message -> Text -> m ()
forall (m :: * -> *) h.
CommandHandlerType m h =>
h -> Message -> Text -> m ()
applyArgs (Message -> b
handler Message
msg) Message
msg Text
input
instance {-# OVERLAPPING #-} (MonadThrow m, ParsableArgument a) => CommandHandlerType m (a -> m ()) where
applyArgs :: (a -> m ()) -> Message -> Text -> m ()
applyArgs a -> m ()
handler Message
msg Text
input = do
let p :: ParsecT Text () Identity (a, Text)
p = (,) (a -> Text -> (a, Text))
-> ParsecT Text () Identity a
-> ParsecT Text () Identity (Text -> (a, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Text () Identity a
forall a. ParsableArgument a => Parser a
parserForArg ParsecT Text () Identity a
-> ParsecT Text () Identity () -> ParsecT Text () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Text () Identity ()
endOrSpaces) ParsecT Text () Identity (Text -> (a, Text))
-> Parsec Text () Text -> ParsecT Text () Identity (a, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parsec Text () Text
forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
case ParsecT Text () Identity (a, Text)
-> SourceName -> Text -> Either ParseError (a, Text)
forall s t a.
Stream s Identity t =>
Parsec s () a -> SourceName -> s -> Either ParseError a
parse ParsecT Text () Identity (a, Text)
p SourceName
"arguments" Text
input of
Left ParseError
e -> CommandError -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (CommandError -> m ()) -> CommandError -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> CommandError
ArgumentParseError (Text -> CommandError) -> Text -> CommandError
forall a b. (a -> b) -> a -> b
$
Text
"Error while parsing argument. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ParseError -> Text
showErrAsText ParseError
e
Right (a
x, Text
remaining) -> m () -> Message -> Text -> m ()
forall (m :: * -> *) h.
CommandHandlerType m h =>
h -> Message -> Text -> m ()
applyArgs (a -> m ()
handler a
x) Message
msg Text
remaining
instance {-# OVERLAPPING #-} (MonadThrow m) => CommandHandlerType m (Message -> m ()) where
applyArgs :: (Message -> m ()) -> Message -> Text -> m ()
applyArgs Message -> m ()
handler Message
msg Text
input = m () -> Message -> Text -> m ()
forall (m :: * -> *) h.
CommandHandlerType m h =>
h -> Message -> Text -> m ()
applyArgs (Message -> m ()
handler Message
msg) Message
msg Text
input
showErrAsText :: ParseError -> T.Text
showErrAsText :: ParseError -> Text
showErrAsText ParseError
err = Text -> Text
T.tail (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ SourceName -> Text
T.pack (SourceName -> Text) -> SourceName -> Text
forall a b. (a -> b) -> a -> b
$ SourceName
-> SourceName
-> SourceName
-> SourceName
-> SourceName
-> [Message]
-> SourceName
showErrorMessages SourceName
"or" SourceName
"unknown parse error"
SourceName
"Expecting" SourceName
"Unexpected" SourceName
"end of message" (ParseError -> [Message]
errorMessages ParseError
err)