{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Command.Parser
( ParsableArgument(..)
, RemainingText(..)
, manyTill1
, endOrSpaces
) where
import Control.Applicative ( liftA2
)
import Control.Monad ( void
, guard
)
import qualified Data.Text as T
import Text.Parsec.Combinator
import qualified Text.Parsec.Text as T
import Text.Parsec
import Discord.Types
manyTill1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill1 :: ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill1 ParsecT s u m a
p ParsecT s u m end
end = do { a
x <- ParsecT s u m a
p; [a]
xs <- ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
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 s u m a
p ParsecT s u m end
end; [a] -> ParsecT s u m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs) }
endOrSpaces :: T.Parser ()
endOrSpaces :: Parser ()
endOrSpaces = Parser ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof Parser () -> Parser () -> Parser ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT Text () Identity Char -> Parser ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
skipMany1 ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space Parser () -> String -> Parser ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"at least one space between arguments"
class ParsableArgument a where
parserForArg :: T.Parser a
instance ParsableArgument String where
parserForArg :: Parser String
parserForArg = do
(Parser String
forall u. ParsecT Text u Identity String
quotedText Parser String -> String -> Parser String
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"quoted phrase") Parser String -> Parser String -> Parser String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Parser String
forall u. ParsecT Text u Identity String
word Parser String -> String -> Parser String
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"word")
where
quotedText :: ParsecT Text u Identity String
quotedText = ParsecT Text u Identity String -> ParsecT Text u Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT Text u Identity String -> ParsecT Text u Identity String)
-> ParsecT Text u Identity String -> ParsecT Text u Identity String
forall a b. (a -> b) -> a -> b
$ do
Char -> ParsecT Text u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"'
String
content <- ParsecT Text u Identity Char -> ParsecT Text u Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT Text u Identity Char -> ParsecT Text u Identity String)
-> ParsecT Text u Identity Char -> ParsecT Text u Identity String
forall a b. (a -> b) -> a -> b
$ ParsecT Text u Identity Char -> ParsecT Text u Identity Char
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (String -> ParsecT Text u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\\\"" ParsecT Text u Identity String
-> ParsecT Text u Identity Char -> ParsecT Text u Identity Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ParsecT Text u Identity Char
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
'"') ParsecT Text u Identity Char
-> ParsecT Text u Identity Char -> ParsecT Text u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> String -> ParsecT Text u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"\""
Char -> ParsecT Text u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"'
String -> ParsecT Text u Identity String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
content
word :: ParsecT Text u Identity String
word =
ParsecT Text u Identity Char
-> ParsecT Text u Identity () -> ParsecT Text u Identity String
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 u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT Text u Identity Char -> ParsecT Text u Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Text u Identity Char -> ParsecT Text u 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 u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space) ParsecT Text u Identity ()
-> ParsecT Text u Identity () -> ParsecT Text u Identity ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT Text u Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof)
instance ParsableArgument T.Text where
parserForArg :: Parser Text
parserForArg = String -> Text
T.pack (String -> Text) -> Parser String -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
forall a. ParsableArgument a => Parser a
parserForArg
instance ParsableArgument [T.Text] where
parserForArg :: Parser [Text]
parserForArg =
(Parser ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof Parser () -> Parser [Text] -> Parser [Text]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Text] -> Parser [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) Parser [Text] -> Parser [Text] -> Parser [Text]
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> do
Text
word <- Parser Text
forall a. ParsableArgument a => Parser a
parserForArg :: T.Parser T.Text
Parser ()
endOrSpaces
[Text]
rest <- Parser [Text]
forall a. ParsableArgument a => Parser a
parserForArg :: T.Parser [T.Text]
[Text] -> Parser [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> Parser [Text]) -> [Text] -> Parser [Text]
forall a b. (a -> b) -> a -> b
$ Text
wordText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
rest
newtype RemainingText = Remaining { RemainingText -> Text
getDeez :: T.Text }
instance ParsableArgument RemainingText where
parserForArg :: Parser RemainingText
parserForArg = do
Char
firstChar <- ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar
Text
remaining <- Parser Text
forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
Text -> Parser ()
forall (m :: * -> *) s u. Monad m => s -> ParsecT s u m ()
setInput Text
""
RemainingText -> Parser RemainingText
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> RemainingText
Remaining (Text -> RemainingText) -> Text -> RemainingText
forall a b. (a -> b) -> a -> b
$ Char -> Text -> Text
T.cons Char
firstChar Text
remaining)
instance (ParsableArgument a) => ParsableArgument (Maybe a) where
parserForArg :: Parser (Maybe a)
parserForArg =
Parser (Maybe a) -> Parser (Maybe a)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> ParsecT Text () Identity a -> Parser (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity a
forall a. ParsableArgument a => Parser a
parserForArg) Parser (Maybe a) -> Parser (Maybe a) -> Parser (Maybe a)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (do
Text
remaining <- Parser Text
forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
Text -> Parser ()
forall (m :: * -> *) s u. Monad m => s -> ParsecT s u m ()
setInput (Text -> Parser ()) -> Text -> Parser ()
forall a b. (a -> b) -> a -> b
$ Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
remaining
Maybe a -> Parser (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
)
instance (ParsableArgument a, ParsableArgument b) => ParsableArgument (a, b) where
parserForArg :: Parser (a, b)
parserForArg = (,) (a -> b -> (a, b))
-> ParsecT Text () Identity a
-> ParsecT Text () Identity (b -> (a, b))
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 (b -> (a, b))
-> ParsecT Text () Identity b -> Parser (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Text () Identity b
forall a. ParsableArgument a => Parser a
parserForArg
instance ParsableArgument Snowflake where
parserForArg :: Parser Snowflake
parserForArg = String -> Snowflake
forall a. Read a => String -> a
read (String -> Snowflake) -> Parser String -> Parser Snowflake
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity Char -> Parser String
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
digit
instance ParsableArgument UpdateStatusType where
parserForArg :: Parser UpdateStatusType
parserForArg =
[Parser UpdateStatusType] -> Parser UpdateStatusType
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice ([Parser UpdateStatusType] -> Parser UpdateStatusType)
-> [Parser UpdateStatusType] -> Parser UpdateStatusType
forall a b. (a -> b) -> a -> b
$ (Parser UpdateStatusType -> Parser UpdateStatusType)
-> [Parser UpdateStatusType] -> [Parser UpdateStatusType]
forall a b. (a -> b) -> [a] -> [b]
map Parser UpdateStatusType -> Parser UpdateStatusType
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try
[ String -> Parser String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"online" Parser String -> Parser UpdateStatusType -> Parser UpdateStatusType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> UpdateStatusType -> Parser UpdateStatusType
forall (f :: * -> *) a. Applicative f => a -> f a
pure UpdateStatusType
UpdateStatusOnline
, String -> Parser String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"dnd" Parser String -> Parser UpdateStatusType -> Parser UpdateStatusType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> UpdateStatusType -> Parser UpdateStatusType
forall (f :: * -> *) a. Applicative f => a -> f a
pure UpdateStatusType
UpdateStatusDoNotDisturb
, String -> Parser String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"idle" Parser String -> Parser UpdateStatusType -> Parser UpdateStatusType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> UpdateStatusType -> Parser UpdateStatusType
forall (f :: * -> *) a. Applicative f => a -> f a
pure UpdateStatusType
UpdateStatusAwayFromKeyboard
, String -> Parser String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"invisible" Parser String -> Parser UpdateStatusType -> Parser UpdateStatusType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> UpdateStatusType -> Parser UpdateStatusType
forall (f :: * -> *) a. Applicative f => a -> f a
pure UpdateStatusType
UpdateStatusInvisibleOffline
]
instance ParsableArgument ActivityType where
parserForArg :: Parser ActivityType
parserForArg =
[Parser ActivityType] -> Parser ActivityType
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice ([Parser ActivityType] -> Parser ActivityType)
-> [Parser ActivityType] -> Parser ActivityType
forall a b. (a -> b) -> a -> b
$ (Parser ActivityType -> Parser ActivityType)
-> [Parser ActivityType] -> [Parser ActivityType]
forall a b. (a -> b) -> [a] -> [b]
map Parser ActivityType -> Parser ActivityType
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try
[ String -> Parser String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"playing" Parser String -> Parser ActivityType -> Parser ActivityType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ActivityType -> Parser ActivityType
forall (f :: * -> *) a. Applicative f => a -> f a
pure ActivityType
ActivityTypeGame
, String -> Parser String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"streaming" Parser String -> Parser ActivityType -> Parser ActivityType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ActivityType -> Parser ActivityType
forall (f :: * -> *) a. Applicative f => a -> f a
pure ActivityType
ActivityTypeStreaming
, String -> Parser String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"listening to" Parser String -> Parser ActivityType -> Parser ActivityType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ActivityType -> Parser ActivityType
forall (f :: * -> *) a. Applicative f => a -> f a
pure ActivityType
ActivityTypeListening
, String -> Parser String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"competing in" Parser String -> Parser ActivityType -> Parser ActivityType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ActivityType -> Parser ActivityType
forall (f :: * -> *) a. Applicative f => a -> f a
pure ActivityType
ActivityTypeCompeting
]