{-# LANGUAGE FlexibleInstances #-} -- allow arbitrary nested types in instance declarations
{-# LANGUAGE OverloadedStrings #-} -- for T.Text overloading
{-|
Module      : Command.Parser
License     : BSD (see the LICENSE file)
Description : Parsers for commands.

Parser component for Commands.
Its usage is mainly internal, to be used from "Command.Command".

If you want to add your own parser argument type, you can either add it here
(to be reused across multiple modules), or in your receive module (if it is only
used there). Either works really, but sometimes you need the other to prevent
looping imports.

-}
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 p end@ is a parser that applies parser @p@ /one/ or more times
-- until parser @end@ succeeds. This is a variation on 'manyTill' from Parsec.
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) }

-- | @eofOrSpaces@ is a parser that parses an end of command, or at least one
-- space and skips the result.
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"

-- | A @ParsableArgument@ is a dataclass that represents arguments that can be
-- parsed from a message text. Any datatype that is an instance of this dataclass
-- can be used as function arguments for a command handler in 'command'.
class ParsableArgument a where
    -- | @parserForArg@ is a parser that returns the parsed element.
    parserForArg :: T.Parser a

-- | Any number of non-space characters. If quoted, spaces are allowed.
-- Quotes in quoted phrases can be escaped with a backslash. The following is
-- parsed as a single string: 
-- @\"He said, \\\"Lovely\\\".\"@
instance ParsableArgument String where
    parserForArg :: Parser String
parserForArg = do
        -- try quoted text first. if it failed, then normal word
        (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 -- backtrack if failed, parse as normal word
            -- consume opening quote
            Char -> ParsecT Text u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"'
            -- consume everything but quotes, unless it is escaped
            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
"\"" 
            -- consume closing quote
            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 =
            -- consume at least one character that is not a space or eof
            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)

-- | Wrapper for the String version, since Text is the trend nowadays.
-- Both are provided so that it can easily be used for arguments in other
-- functions that only accept one of the types.
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

-- | Zero or more texts. Each one could be quoted or not.
instance ParsableArgument [T.Text] where
    parserForArg :: Parser [Text]
parserForArg =
        -- if it's the end, return empty (base case).
        (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
            -- do the usual text parsing
            Text
word <- Parser Text
forall a. ParsableArgument a => Parser a
parserForArg :: T.Parser T.Text
            Parser ()
endOrSpaces
            -- recursively do this and append
            [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

-- | Datatype wrapper for the remaining text in the input. Handy for capturing
-- everything remaining. The accessor function @getDeez@ isn't really meant to be
-- used since pattern matching can do everything. Open to renaming.
--
-- Example usage:
--
-- @
-- setStatus =
--     command "status"
--     $ \\msg newStatus newType (Remaining newName) -> do
--         ...
-- @
newtype RemainingText = Remaining { RemainingText -> Text
getDeez :: T.Text }

-- | The rest of the arguments. Spaces and quotes are preserved as-is, unlike
-- with @Text@. At least one character is required.
instance ParsableArgument RemainingText where
    parserForArg :: Parser RemainingText
parserForArg = do
        -- Make sure at least one character is present
        -- This is guaranteed to not be a space, because previous parsers
        -- consume trailing spaces.
        Char
firstChar <- ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar
        -- Get the rest of the input.
        -- This is more convenient than doing "many anyChar" because it doesn't
        -- need to parse anything for the remaining input.
        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)

-- | An argument that can or cannot exist. 
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
            -- artifically put a space so it won't complain about missing
            -- spaces between arguments.
            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
            )

-- Integer. TODO
-- instance ParsableArgument Int where
--     parserForArg msg =

-- Float. TODO don't even know if we need this.
-- instance ParsableArgument Float where
--     parserForArg msg =

-- | An argument that always has to be followed by another.
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

-- | Parses "online" "dnd" "idle" and "invisible" as 'UpdateStatusType's
instance ParsableArgument UpdateStatusType where
    parserForArg :: Parser UpdateStatusType
parserForArg =
        -- consume either of the following:
        -- (if fail then backtrack using try)
        [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
            ]

-- | Parses "playing", "streaming", "listening to" and "competing in" as
-- 'ActivityType's.
instance ParsableArgument ActivityType where
    parserForArg :: Parser ActivityType
parserForArg =
        -- consume either of the following:
        -- (if fail then backtrack using try)
        [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
            ]