diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # Changelog for Calamity +## 0.1.9.1 + +*2020-05-23* + +* Added `Calamity.Commands.Parser.Named` for parameters that have a name. + +* General improvements to parser errors + ## 0.1.9.0 *2020-05-22* diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -110,19 +110,25 @@ void . P.runFinal . P.embedToFinal . runCounterAtomic . runCacheInMemory . runMetricsPrometheusIO . useConstantPrefix "!" $ runBotIO (BotToken token) $ do addCommands $ do - command @'[Text, Snowflake User] "test" $ \ctx something aUser -> do + command @'[L.Text, Snowflake User] "test" $ \ctx something aUser -> do info $ "something = " <> showt something <> ", aUser = " <> showt aUser command @'[] "hello" $ \ctx -> do void $ tellt ctx "heya" group "testgroup" $ do - command @'[[Text]] "test" $ \ctx l -> do + command @'[[L.Text]] "test" $ \ctx l -> do void $ tellt ctx ("you sent: " <> showtl l) command @'[] "count" $ \ctx -> do val <- getCounter void $ tellt ctx ("The value is: " <> showtl val) group "say" $ do - command @'[KleeneConcat Text] "this" $ \ctx msg -> do + command @'[KleeneConcat L.Text] "this" $ \ctx msg -> do void $ tellt ctx msg + command @'[User] "utest" $ \ctx u -> do + void $ tellt ctx $ "got user: " <> showtl u + command @'[Named "u" User, Named "u1" User] "utest2" $ \ctx u u1 -> do + void $ tellt ctx $ "got user: " <> showtl u <> "\nand: " <> showtl u1 + command @'[Snowflake Emoji] "etest" $ \ctx e -> do + void $ tellt ctx $ "got emoji: " <> showtl e command @'[] "explode" $ \ctx -> do Just x <- pure Nothing debug "unreachable!" @@ -130,8 +136,8 @@ void $ tellt ctx "bye!" stopBot command @'[] "fire-evt" $ \ctx -> do - fire $ customEvt @"my-event" ("aha" :: Text, ctx ^. #message) - command @'[Text] "wait-for" $ \ctx s -> do + fire $ customEvt @"my-event" ("aha" :: L.Text, ctx ^. #message) + command @'[L.Text] "wait-for" $ \ctx s -> do void $ tellt ctx ("waiting for !" <> s) waitUntil @'MessageCreateEvt (\msg -> msg ^. #content == ("!" <> s)) void $ tellt ctx ("got !" <> s) @@ -148,7 +154,7 @@ react @('CustomEvt "command-error" (CommandContext.Context, CommandError)) $ \(ctx, e) -> do info $ "Command failed with reason: " <> showt e case e of - ParseError t r -> void . tellt ctx $ "Failed to parse parameter: " <> L.fromStrict t <> ", with reason: ```\n" <> r <> "```" - react @('CustomEvt "my-event" (Text, Message)) $ \(s, m) -> + ParseError n r -> void . tellt ctx $ "Failed to parse parameter: `" <> L.fromStrict n <> "`, with reason: ```\n" <> r <> "```" + react @('CustomEvt "my-event" (L.Text, Message)) $ \(s, m) -> void $ tellt m ("Somebody told me to tell you about: " <> s) ``` diff --git a/calamity.cabal b/calamity.cabal --- a/calamity.cabal +++ b/calamity.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: bcd0c50d2410522101e3729e6c1c6f0d6a5830f977929848fc4a7507d8af872b +-- hash: 3c7ebdf28eac3707c7b4322aa4cfcd2c315be4e5a0d442d83e1ae4ad4bb5fcab name: calamity -version: 0.1.9.0 +version: 0.1.9.1 synopsis: A library for writing discord bots description: Please see the README on GitHub at category: Network, Web diff --git a/src/Calamity/Commands.hs b/src/Calamity/Commands.hs --- a/src/Calamity/Commands.hs +++ b/src/Calamity/Commands.hs @@ -11,4 +11,4 @@ import Calamity.Commands.Error import Calamity.Commands.Handler import Calamity.Commands.ParsePrefix -import Calamity.Commands.Parser +import Calamity.Commands.Parser hiding ( ParserState, SpannedError ) diff --git a/src/Calamity/Commands/CommandUtils.hs b/src/Calamity/Commands/CommandUtils.hs --- a/src/Calamity/Commands/CommandUtils.hs +++ b/src/Calamity/Commands/CommandUtils.hs @@ -26,11 +26,12 @@ import Data.Maybe import Data.Text as S import Data.Text.Lazy as L -import Data.Typeable import qualified Polysemy as P import qualified Polysemy.Error as P import qualified Polysemy.Fail as P +import qualified Polysemy.Reader as P +import qualified Polysemy.State as P buildCommand' :: P.Member (P.Final IO) r => S.Text @@ -60,9 +61,9 @@ => S.Text -> (Context -> P.Sem r (Either CommandError a)) -> P.Sem r (Context -> IO (Either CommandError a)) -buildParser cmdName cb = do +buildParser name cb = do cb' <- bindSemToIO cb - let cb'' ctx = fromMaybe (Left $ ParseError ("Parser for command: " <> cmdName) "failed internally") <$> cb' ctx + let cb'' ctx = fromMaybe (Left $ ParseError ("Parser for command: " <> name) "failed internally") <$> cb' ctx pure cb'' buildCallback @@ -88,18 +89,16 @@ type TypedCommandC ps a r = ( ApplyTupRes a (CommandSemType r) ~ CommandForParsers ps r - , a ~ ParamsFromParsers ps - , BuildTypedCommandParser ps r + , a ~ ParserResult (ListToTup ps) + , Parser (ListToTup ps) r , ApplyTup a (CommandSemType r)) buildTypedCommand :: forall (ps :: [Type]) a r. TypedCommandC ps a r => (Context -> CommandForParsers ps r) - -> ( Context - -> P.Sem r (Either CommandError a) - , (Context, a) - -> P.Sem (P.Fail ': r) ()) + -> ( Context -> P.Sem r (Either CommandError a) + , (Context, a) -> P.Sem (P.Fail ': r) ()) buildTypedCommand cmd = let parser ctx = buildTypedCommandParser @ps (ctx, ctx ^. #unparsedParams) consumer (ctx, r) = applyTup (cmd ctx) r in (parser, consumer) @@ -119,20 +118,14 @@ applyTup r () = r -class BuildTypedCommandParser (ps :: [Type]) r where - buildTypedCommandParser :: (Context, L.Text) -> P.Sem r (Either CommandError (ParamsFromParsers ps)) - -instance BuildTypedCommandParser '[] r where - buildTypedCommandParser (_, _) = pure $ Right () - -instance (Typeable x, Parser x r, BuildTypedCommandParser xs r) => BuildTypedCommandParser (x ': xs) r where - buildTypedCommandParser (ctx, msg) = parse @x (ctx, msg) >>= \case - Right (a, msg') -> (a, ) <<$>> buildTypedCommandParser @xs (ctx, msg') - Left e -> pure $ Left (ParseError (S.pack . show . typeRep $ Proxy @x) e) +buildTypedCommandParser :: forall (ps :: [Type]) r. Parser (ListToTup ps) r => (Context, L.Text) -> P.Sem r (Either CommandError (ParserResult (ListToTup ps))) +buildTypedCommandParser (ctx, t) = (P.runReader ctx . P.runError . P.evalState (ParserState 0 t) $ parse @(ListToTup ps)) <&> \case + Right r -> Right r + Left (n, e) -> Left $ ParseError n e -type family ParamsFromParsers (ps :: [Type]) where - ParamsFromParsers '[] = () - ParamsFromParsers (x ': xs) = (ParserResult x, ParamsFromParsers xs) +type family ListToTup (ps :: [Type]) where + ListToTup '[] = () + ListToTup (x ': xs) = (x, ListToTup xs) type family CommandForParsers (ps :: [Type]) r where CommandForParsers '[] r = P.Sem (P.Fail ': r) () diff --git a/src/Calamity/Commands/Handler.hs b/src/Calamity/Commands/Handler.hs --- a/src/Calamity/Commands/Handler.hs +++ b/src/Calamity/Commands/Handler.hs @@ -100,11 +100,6 @@ nextWord :: L.Text -> (L.Text, L.Text) nextWord = L.break isSpace . L.stripStart -firstEither :: Either e a -> Either e a -> Either e a -firstEither (Right l) _ = Right l -firstEither l (Left _) = l -firstEither _ r = r - findCommand :: CommandHandler -> L.Text -> Either [L.Text] (Command, L.Text) findCommand handler msg = goH $ nextWord msg where @@ -112,13 +107,13 @@ goH ("", _) = Left [] goH (x, xs) = attachSoFar x (((, xs) <$> attachInitial (LH.lookup (L.toStrict x) (handler ^. #commands))) - `firstEither` (attachInitial (LH.lookup (L.toStrict x) (handler ^. #groups)) >>= goG (nextWord xs))) + <> (attachInitial (LH.lookup (L.toStrict x) (handler ^. #groups)) >>= goG (nextWord xs))) goG :: (L.Text, L.Text) -> Group -> Either [L.Text] (Command, L.Text) goG ("", _) _ = Left [] goG (x, xs) g = attachSoFar x (((, xs) <$> attachInitial (LH.lookup (L.toStrict x) (g ^. #commands))) - `firstEither` (attachInitial (LH.lookup (L.toStrict x) (g ^. #children)) >>= goG (nextWord xs))) + <> (attachInitial (LH.lookup (L.toStrict x) (g ^. #children)) >>= goG (nextWord xs))) attachInitial :: Maybe a -> Either [L.Text] a attachInitial (Just a) = Right a diff --git a/src/Calamity/Commands/Parser.hs b/src/Calamity/Commands/Parser.hs --- a/src/Calamity/Commands/Parser.hs +++ b/src/Calamity/Commands/Parser.hs @@ -1,121 +1,192 @@ -- | Something that can parse user input module Calamity.Commands.Parser ( Parser(..) - , KleeneConcat ) where + , Named + , KleeneConcat + , ParserState(..) + , SpannedError(..) ) where import Calamity.Cache.Eff import Calamity.Commands.Context -import Calamity.Internal.Utils -import Calamity.Types.Model.Channel ( Channel ) -import Calamity.Types.Model.Guild ( Emoji, Member, Role ) -import Calamity.Types.Model.User ( User ) +import Calamity.Types.Model.Channel ( Channel ) +import Calamity.Types.Model.Guild ( Emoji, Member, Role ) +import Calamity.Types.Model.User ( User ) import Calamity.Types.Snowflake -import Control.Lens hiding ( Context ) +import Control.Lens hiding ( Context ) import Control.Monad +import Control.Monad.Trans ( lift ) -import Data.Bifunctor -import Data.Char ( isSpace ) +import Data.Char ( isSpace ) import Data.Kind -import Data.List.NonEmpty ( NonEmpty, nonEmpty ) -import qualified Data.Text.Lazy as L -import Data.Text.Lazy ( Text ) +import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.Text as S +import qualified Data.Text.Lazy as L +import Data.Text.Lazy ( Text ) import Data.Typeable -import qualified Polysemy as P +import GHC.Generics ( Generic ) +import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal ) -import Text.Megaparsec hiding ( parse ) +import qualified Polysemy as P +import qualified Polysemy.Error as P +import qualified Polysemy.Reader as P +import qualified Polysemy.State as P + +import Text.Megaparsec hiding ( parse ) import Text.Megaparsec.Char +import Text.Megaparsec.Error.Builder ( errFancy, fancy ) -import TextShow +data SpannedError = SpannedError Text !Int !Int + deriving ( Show, Eq, Ord ) -class Parser (a :: Type) r where +showTypeOf :: forall a. Typeable a => String +showTypeOf = show . typeRep $ Proxy @a + +data ParserState = ParserState + { off :: Int + , msg :: Text + } + deriving ( Show, Generic ) + +type ParserEffs r = P.State ParserState ': P.Error (S.Text, Text) ': P.Reader Context ': r +type ParserCtxE r = P.Reader Context ': r + +class Typeable a => Parser (a :: Type) r where type ParserResult a type ParserResult a = a - parse :: (Context, Text) -> P.Sem r (Either Text (ParserResult a, Text)) + name :: S.Text + default name :: S.Text + name = ":" <> S.pack (showTypeOf @a) + parse :: P.Sem (ParserEffs r) (ParserResult a) + +data Named (s :: Symbol) a + +instance (KnownSymbol s, Parser a r) => Parser (Named s a) r where + type ParserResult (Named s a) = ParserResult a + + name = (S.pack . symbolVal $ Proxy @s) <> name @a @r + + parse = mapE (_1 .~ name @(Named s a) @r) $ parse @a @r + +mapE :: P.Member (P.Error e) r => (e -> e) -> P.Sem r a -> P.Sem r a +mapE f m = P.catch m (P.throw . f) + +parseMP :: S.Text -> ParsecT SpannedError Text (P.Sem (ParserCtxE r)) a -> P.Sem (ParserEffs r) a +parseMP n m = do + s <- P.get + res <- P.raise . P.raise $ runParserT (skipN (s ^. #off) *> trackOffsets (space *> m)) "" (s ^. #msg) + case res of + Right (a, offset) -> do + P.modify (#off +~ offset) + pure a + Left s -> P.throw (n, L.pack $ errorBundlePretty s) + instance Parser Text r where - parse (_ctx, msg) = pure $ runParserToCommandError item msg + parse = parseMP (name @Text) item +instance Parser a r => Parser (Maybe a) r where + type ParserResult (Maybe a) = Maybe (ParserResult a) + + parse = P.catch (Just <$> parse @a) (const $ pure Nothing) + instance Parser a r => Parser [a] r where type ParserResult [a] = [ParserResult a] - parse (ctx, msg) = Right <$> go msg [] - where - go :: Text -> [ParserResult a] -> P.Sem r ([ParserResult a], Text) - go t l = parse @a (ctx, t) >>= \case - Left _ -> pure (l, t) - Right (v, t') -> go t' (l <> [v]) + parse = go [] + where go :: [ParserResult a] -> P.Sem (ParserEffs r) [ParserResult a] + go l = P.catch ((: []) <$> parse @a) (const $ pure []) >>= go . (l ++) instance (Parser a r, Typeable a) => Parser (NonEmpty a) r where type ParserResult (NonEmpty a) = NonEmpty (ParserResult a) - parse (ctx, msg) = parse @[a] (ctx, msg) - <&> (\case - Right (res, rest) -> case nonEmpty res of - Just res' -> Right (res', rest) - Nothing -> Left ("Couldn't parse at least one of " <> (L.pack . show . typeRep $ Proxy @a)) - Left e -> Left e) + parse = do + a <- parse @a + as <- parse @[a] + pure $ a :| as data KleeneConcat a instance (Monoid (ParserResult a), Parser a r) => Parser (KleeneConcat a) r where type ParserResult (KleeneConcat a) = ParserResult a - parse (ctx, msg) = (first mconcat) <<$>> parse @[a] (ctx, msg) + parse = mconcat <$> parse @[a] instance {-# OVERLAPS #-}Parser (KleeneConcat Text) r where type ParserResult (KleeneConcat Text) = ParserResult Text -- consume rest on text just takes everything remaining - parse (_ctx, msg) = pure $ runParserToCommandError (someSingle) msg + parse = parseMP (name @(KleeneConcat Text)) someSingle -instance Parser (Snowflake a) r where - parse (_ctx, msg) = pure $ runParserToCommandError snowflake msg +instance Typeable (Snowflake a) => Parser (Snowflake a) r where + parse = parseMP (name @(Snowflake a)) snowflake instance {-# OVERLAPS #-}Parser (Snowflake User) r where - parse (_ctx, msg) = pure $ runParserToCommandError (try (ping "@") <|> snowflake) msg + parse = parseMP (name @(Snowflake User)) (try (ping "@") <|> snowflake) instance {-# OVERLAPS #-}Parser (Snowflake Member) r where - parse (_ctx, msg) = pure $ runParserToCommandError (try (ping "@") <|> snowflake) msg + parse = parseMP (name @(Snowflake Member)) (try (ping "@") <|> snowflake) instance {-# OVERLAPS #-}Parser (Snowflake Channel) r where - parse (_ctx, msg) = pure $ runParserToCommandError (try (ping "#") <|> snowflake) msg + parse = parseMP (name @(Snowflake Channel)) (try (ping "#") <|> snowflake) instance {-# OVERLAPS #-}Parser (Snowflake Role) r where - parse (_ctx, msg) = pure $ runParserToCommandError (try (ping "@&") <|> snowflake) msg + parse = parseMP (name @(Snowflake Role)) (try (ping "@&") <|> snowflake) instance {-# OVERLAPS #-}Parser (Snowflake Emoji) r where - parse (_ctx, msg) = pure $runParserToCommandError - (try emoji <|> snowflake) msg + parse = parseMP (name @(Snowflake Emoji)) (try emoji <|> snowflake) +-- mapParserMaybe :: Stream s => ParsecT SpannedError s m a -> Text -> (a -> Maybe b) -> ParsecT SpannedError s m b +-- mapParserMaybe m e f = do +-- offs <- getOffset +-- r <- f <$> m +-- offe <- getOffset +-- case r of +-- Just r' -> pure r' +-- _ -> parseError . errFancy offs . fancy . ErrorCustom $ SpannedError e offs offe +mapParserMaybeM :: (Monad m, Stream s) => ParsecT SpannedError s m a -> Text -> (a -> m (Maybe b)) -> ParsecT SpannedError s m b +mapParserMaybeM m e f = do + offs <- getOffset + r <- m >>= lift . f + offe <- getOffset + case r of + Just r' -> pure r' + _ -> parseError . errFancy offs . fancy . ErrorCustom $ SpannedError e offs offe + instance Parser Member r where - parse (ctx, msg) = parse @(Snowflake Member) (ctx, msg) - <&> (>>= \(mid, rest) -> case ctx ^? #guild . _Just . #members . ix mid of - Just member -> Right (member, rest) - _ -> Left ("Couldn't find member with id: " <> showtl mid)) + parse = parseMP (name @Member) $ mapParserMaybeM (try (ping "@") <|> snowflake) + "Couldn't find a Member with this id" + (\mid -> do + ctx <- P.ask + pure $ ctx ^? #guild . _Just . #members . ix mid) instance P.Member CacheEff r => Parser User r where - parse (ctx, msg) = do - r <- parse @(Snowflake User) (ctx, msg) - case r of - Right (uid, rest) -> getUser uid <&> \case - Just member -> Right (member, rest) - _ -> Left ("Couldn't find user with id: " <> showtl uid) - Left e -> pure $ Left e + parse = parseMP (name @User @r) $ mapParserMaybeM (try (ping "@") <|> snowflake) + "Couldn't find a User with this id" + getUser -instance ShowErrorComponent Text where - showErrorComponent = L.unpack - errorComponentLen = fromIntegral . L.length +instance (Parser a r, Parser b r) => Parser (a, b) r where + type ParserResult (a, b) = (ParserResult a, ParserResult b) -runParserToCommandError :: Parsec Text Text a -> Text -> Either Text (a, Text) -runParserToCommandError m t = case runParser (space *> andRemaining m) "" t of - Right a -> Right a - Left s -> Left . L.pack . errorBundlePretty $ s + parse = do + a <- parse @a + b <- parse @b + pure (a, b) +instance Parser () r where + parse = parseMP (name @()) space + +instance ShowErrorComponent SpannedError where + showErrorComponent (SpannedError t _ _) = L.unpack t + errorComponentLen (SpannedError _ s e) = max 1 $ e - s + +skipN :: (Stream s, Ord e) => Int -> ParsecT e s m () +skipN n = void $ takeP Nothing n + ping :: MonadParsec e Text m => Text -> m (Snowflake a) ping c = chunk ("<" <> c) *> optional (chunk "!") *> snowflake <* chunk ">" @@ -128,27 +199,28 @@ emoji :: MonadParsec e Text m => m (Snowflake a) emoji = ping' (optional (chunk "a") *> between (chunk ":") (chunk ":") (void $ takeWhileP Nothing $ not . (== ':'))) -andRemaining :: MonadParsec e s m => m a -> m (a, Tokens s) -andRemaining m = do +trackOffsets :: MonadParsec e s m => m a -> m (a, Int) +trackOffsets m = do + offs <- getOffset a <- m - rest <- manySingle - pure (a, rest) + offe <- getOffset + pure (a, offe - offs) item :: MonadParsec e Text m => m Text item = try quotedString <|> someNonWS -manySingle :: MonadParsec e s m => m (Tokens s) -manySingle = takeWhileP (Just "Any character") (const True) +-- manySingle :: MonadParsec e s m => m (Tokens s) +-- manySingle = takeWhileP (Just "Any character") (const True) someSingle :: MonadParsec e s m => m (Tokens s) -someSingle = takeWhile1P (Just "Any character") (const True) +someSingle = takeWhile1P (Just "any character") (const True) quotedString :: MonadParsec e Text m => m Text -quotedString = try (between (chunk "'") (chunk "'") (takeWhileP Nothing $ not . (== '\''))) <|> - between (chunk "\"") (chunk "\"") (takeWhileP Nothing $ not . (== '"')) +quotedString = try (between (chunk "'") (chunk "'") (takeWhileP (Just "any character") $ not . (== '\''))) <|> + between (chunk "\"") (chunk "\"") (takeWhileP (Just "any character") $ not . (== '"')) -- manyNonWS :: (Token s ~ Char, MonadParsec e s m) => m (Tokens s) -- manyNonWS = takeWhileP (Just "Any Non-Whitespace") (not . isSpace) someNonWS :: (Token s ~ Char, MonadParsec e s m) => m (Tokens s) -someNonWS = takeWhile1P (Just "Any Non-Whitespace") (not . isSpace) +someNonWS = takeWhile1P (Just "any non-whitespace") (not . isSpace)