calamity 0.1.9.0 → 0.1.9.1

raw patch · 7 files changed

+180/−106 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• README.md +13/−7
• calamity.cabal +2/−2
• src/Calamity/Commands.hs +1/−1
• src/Calamity/Commands/CommandUtils.hs +15/−22
• src/Calamity/Commands/Handler.hs +2/−7
• src/Calamity/Commands/Parser.hs +139/−67

@@ -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*

@@ -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) ```

@@ -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 <https://github.com/nitros12/calamity#readme> category:       Network, Web

@@ -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 )

@@ -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) ()

@@ -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

@@ -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)