calamity 0.1.9.1 → 0.1.9.2

raw patch · 13 files changed

+389/−200 lines, 13 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• calamity.cabal +5/−3
• src/Calamity/Commands.hs +6/−2
• src/Calamity/Commands/Command.hs +4/−2
• src/Calamity/Commands/CommandUtils.hs +28/−17
• src/Calamity/Commands/Dsl.hs +12/−7
• src/Calamity/Commands/Group.hs +20/−0
• src/Calamity/Commands/Handler.hs +7/−108
• src/Calamity/Commands/Help.hs +105/−0
• src/Calamity/Commands/LocalWriter.hs +0/−27
• src/Calamity/Commands/Parser.hs +46/−34
• src/Calamity/Commands/Utils.hs +121/−0
• src/Calamity/Internal/LocalWriter.hs +27/−0

@@ -1,5 +1,13 @@ # Changelog for Calamity +## 0.1.9.2++*2020-05-23*++* Added a default help command, located in `Calamity.Commands.Help`.++* Commands now have the list of parameters they take+ ## 0.1.9.1  *2020-05-23*

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 3c7ebdf28eac3707c7b4322aa4cfcd2c315be4e5a0d442d83e1ae4ad4bb5fcab+-- hash: ab08a364b5d3e67e015dfa8b1e5a96b8255ea898856a72811e1d1462bb984147  name:           calamity-version:        0.1.9.1+version:        0.1.9.2 synopsis:       A library for writing discord bots description:    Please see the README on GitHub at <https://github.com/nitros12/calamity#readme> category:       Network, Web@@ -49,9 +49,10 @@       Calamity.Commands.Error       Calamity.Commands.Group       Calamity.Commands.Handler-      Calamity.Commands.LocalWriter+      Calamity.Commands.Help       Calamity.Commands.ParsePrefix       Calamity.Commands.Parser+      Calamity.Commands.Utils       Calamity.Gateway       Calamity.Gateway.DispatchEvents       Calamity.Gateway.Shard@@ -73,6 +74,7 @@       Calamity.Internal.AesonThings       Calamity.Internal.BoundedStore       Calamity.Internal.GenericCurry+      Calamity.Internal.LocalWriter       Calamity.Internal.RunIntoIO       Calamity.Internal.SnowflakeMap       Calamity.Internal.Updateable

@@ -4,11 +4,15 @@     ( module Calamity.Commands.Dsl     , module Calamity.Commands.Error     , module Calamity.Commands.Handler+    , module Calamity.Commands.Utils     , module Calamity.Commands.ParsePrefix-    , module Calamity.Commands.Parser ) where+    , module Calamity.Commands.Parser+    , module Calamity.Commands.Help ) where  import           Calamity.Commands.Dsl import           Calamity.Commands.Error import           Calamity.Commands.Handler+import           Calamity.Commands.Help import           Calamity.Commands.ParsePrefix-import           Calamity.Commands.Parser hiding ( ParserState, SpannedError )+import           Calamity.Commands.Parser+import           Calamity.Commands.Utils

@@ -21,6 +21,7 @@   { name     :: S.Text   , parent   :: Maybe Group   , checks   :: [Check]+  , params   :: [S.Text]   , help     :: Context -> L.Text   , parser   :: Context -> IO (Either CommandError a)   , callback :: (Context, a) -> IO (Maybe L.Text)@@ -28,6 +29,7 @@  data CommandS = CommandS   { name   :: S.Text+  , params :: [S.Text]   , parent :: Maybe S.Text   , checks :: [S.Text]   }@@ -35,9 +37,9 @@   deriving ( TextShow ) via TSG.FromGeneric CommandS  instance Show Command where-  showsPrec d Command { name, parent, checks } = showsPrec d $ CommandS name (parent ^? _Just . #name)+  showsPrec d Command { name, params, parent, checks } = showsPrec d $ CommandS name params (parent ^? _Just . #name)     (checks ^.. traverse . #name)  instance TextShow Command where-  showbPrec d Command { name, parent, checks } = showbPrec d $ CommandS name (parent ^? _Just . #name)+  showbPrec d Command { name, params, parent, checks } = showbPrec d $ CommandS name params (parent ^? _Just . #name)     (checks ^.. traverse . #name)

@@ -30,24 +30,23 @@ 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               -> Maybe Group               -> [Check]+              -> [S.Text]               -> (Context -> L.Text)               -> (Context -> P.Sem r (Either CommandError a))               -> ((Context, a) -> P.Sem (P.Fail ': r) ())               -> P.Sem r Command-buildCommand' name parent checks help parser cb = do+buildCommand' name parent checks params help parser cb = do   cb' <- buildCallback cb   parser' <- buildParser name parser-  pure $ Command name parent checks help parser' cb'+  pure $ Command name parent checks params help parser' cb' -buildCommand :: forall ps a r.-             (P.Member (P.Final IO) r, TypedCommandC ps a r)+buildCommand :: forall ps r.+             (P.Member (P.Final IO) r, TypedCommandC ps r)              => S.Text              -> Maybe Group              -> [Check]@@ -55,7 +54,7 @@              -> (Context -> CommandForParsers ps r)              -> P.Sem r Command buildCommand name parent checks help command = let (parser, cb) = buildTypedCommand @ps command-                                               in buildCommand' name parent checks help parser cb+                                               in buildCommand' name parent checks (paramNames @ps @r) help parser cb  buildParser :: P.Member (P.Final IO) r             => S.Text@@ -87,22 +86,34 @@  type CommandSemType r = P.Sem (P.Fail ': r) () -type TypedCommandC ps a r =-  ( ApplyTupRes a (CommandSemType r) ~ CommandForParsers ps r-  , a ~ ParserResult (ListToTup ps)+type TypedCommandC ps r =+  ( ApplyTupRes (ParserResult (ListToTup ps)) (CommandSemType r) ~ CommandForParsers ps r   , Parser (ListToTup ps) r-  , ApplyTup a (CommandSemType r))+  , ApplyTup (ParserResult (ListToTup ps)) (CommandSemType r)+  , ParamNamesForParsers ps r+  )  buildTypedCommand   :: forall (ps :: [Type]) a r.-  TypedCommandC ps a r+  (TypedCommandC ps r, a ~ ParserResult (ListToTup ps))   => (Context -> CommandForParsers ps 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)+  -> ( 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) +class ParamNamesForParsers (ps :: [Type]) r where+  paramNames :: [S.Text]++instance ParamNamesForParsers '[] r where+  paramNames = []++instance (Parser x r, ParamNamesForParsers xs r) => ParamNamesForParsers (x : xs) r where+  paramNames = (parserName @x @r : paramNames @xs @r)+ class ApplyTup a b where   type ApplyTupRes a b @@ -118,8 +129,8 @@    applyTup r () = r -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+buildTypedCommandParser :: forall (ps :: [Type]) r. Parser (ListToTup ps) r => Context -> L.Text -> P.Sem r (Either CommandError (ParserResult (ListToTup ps)))+buildTypedCommandParser ctx t = (runCommandParser ctx t $ parse @(ListToTup ps) @r) <&> \case   Right r -> Right r   Left (n, e)  -> Left $ ParseError n e 

@@ -18,7 +18,8 @@ import           Calamity.Commands.Context     hiding ( command ) import           Calamity.Commands.Error import           Calamity.Commands.Group       hiding ( help )-import           Calamity.Commands.LocalWriter+import           Calamity.Commands.Handler+import           Calamity.Internal.LocalWriter  import qualified Data.HashMap.Lazy             as LH import qualified Data.Text                     as S@@ -34,29 +35,31 @@                        P.Reader (Maybe Group) ':                        P.Reader (Context -> L.Text) ':                        P.Reader [Check] ':+                       P.Reader CommandHandler ':                        P.Fixpoint ': r)  raiseDSL :: P.Sem r a -> P.Sem (DSLState r) a-raiseDSL = P.raise . P.raise . P.raise . P.raise . P.raise . P.raise+raiseDSL = P.raise . P.raise . P.raise . P.raise . P.raise . P.raise . P.raise  -- | Build a command with an already prepared invokation action command'   :: P.Member (P.Final IO) r   => S.Text+  -> [S.Text]   -> (Context -> P.Sem r (Either CommandError a))   -> ((Context, a) -> P.Sem (P.Fail ': r) ())   -> P.Sem (DSLState r) Command-command' name parser cb = do+command' name params parser cb = do   parent <- P.ask @(Maybe Group)   checks <- P.ask @[Check]   help' <- P.ask @(Context -> L.Text)-  cmd <- raiseDSL $ buildCommand' name parent checks help' parser cb+  cmd <- raiseDSL $ buildCommand' name parent checks params help' parser cb   ltell $ LH.singleton name cmd   pure cmd -command :: forall ps a r.+command :: forall ps r.         ( P.Member (P.Final IO) r,-          TypedCommandC ps a r)+          TypedCommandC ps r)         => S.Text         -> (Context -> CommandForParsers ps r)         -> P.Sem (DSLState r) Command@@ -102,7 +105,9 @@   checks <- P.ask @[Check]   help'  <- P.ask @(Context -> L.Text)   let group' = Group name parent commands children help' checks-  (children, (commands, res)) <- llisten @(LH.HashMap S.Text Group) $ llisten @(LH.HashMap S.Text Command) $ P.local (const $ Just group') m+  (children, (commands, res)) <- llisten @(LH.HashMap S.Text Group) $+                                 llisten @(LH.HashMap S.Text Command) $+                                 P.local @(Maybe Group) (const $ Just group') m   ltell $ LH.singleton name group'   pure res 

@@ -6,12 +6,17 @@ import {-# SOURCE #-} Calamity.Commands.Command import {-# SOURCE #-} Calamity.Commands.Context +import           Control.Lens              hiding ( (<.>), Context )+ import qualified Data.HashMap.Lazy         as LH import qualified Data.Text                 as S import qualified Data.Text.Lazy            as L  import           GHC.Generics +import           TextShow+import qualified TextShow.Generic          as TSG+ data Group = Group   { name     :: S.Text   , parent   :: Maybe Group@@ -21,3 +26,18 @@   , checks   :: [Check]   }   deriving ( Generic )++data GroupS = GroupS+  { name     :: S.Text+  , parent   :: Maybe S.Text+  , commands :: LH.HashMap S.Text Command+  , children :: LH.HashMap S.Text Group+  }+  deriving ( Generic, Show )+  deriving ( TextShow ) via TSG.FromGeneric GroupS++instance Show Group where+  showsPrec d Group { name, parent, commands, children } = showsPrec d $ GroupS name (parent ^? _Just . #name) commands children++instance TextShow Group where+  showbPrec d Group { name, parent, commands, children } = showbPrec d $ GroupS name (parent ^? _Just . #name) commands children

@@ -1,41 +1,17 @@ -- | A command handler module Calamity.Commands.Handler-    ( CommandHandler(..)-    , addCommands-    , buildCommands-    , buildContext ) where+    ( CommandHandler(..) ) where -import           Calamity.Cache.Eff-import           Calamity.Client.Client-import           Calamity.Client.Types import           Calamity.Commands.Command-import           Calamity.Commands.CommandUtils-import           Calamity.Commands.Context-import           Calamity.Commands.Dsl-import           Calamity.Commands.Error import           Calamity.Commands.Group-import           Calamity.Commands.LocalWriter-import           Calamity.Commands.ParsePrefix-import           Calamity.Internal.Utils-import           Calamity.Types.Model.Channel-import           Calamity.Types.Model.User-import           Calamity.Types.Snowflake -import           Control.Lens                   hiding ( Context )-import           Control.Monad--import           Data.Char                      ( isSpace )-import qualified Data.HashMap.Lazy              as LH-import qualified Data.Text                      as S-import qualified Data.Text.Lazy                 as L+import qualified Data.HashMap.Lazy         as LH+import qualified Data.Text                 as S  import           GHC.Generics -import qualified Polysemy                       as P-import qualified Polysemy.Error                 as P-import qualified Polysemy.Fail                  as P-import qualified Polysemy.Fixpoint              as P-import qualified Polysemy.Reader                as P+import           TextShow+import qualified TextShow.Generic          as TSG  data CommandHandler = CommandHandler   { groups   :: LH.HashMap S.Text Group@@ -43,82 +19,5 @@   , commands :: LH.HashMap S.Text Command     -- ^ Top level commands   }-  deriving ( Generic )--mapLeft :: (e -> e') -> Either e a -> Either e' a-mapLeft f (Left x)  = Left $ f x-mapLeft _ (Right x) = Right x--data FailReason-  = NoPrefix-  | NoCtx-  | NF [L.Text]-  | ERR Context CommandError--addCommands :: (BotC r, P.Member ParsePrefix r) => P.Sem (DSLState r) a -> P.Sem r (P.Sem r (), CommandHandler, a)-addCommands m = do-  (handler, res) <- buildCommands m-  remove <- react @'MessageCreateEvt $ \msg -> do-    err <- P.runError $ do-      (prefix, rest) <- P.note NoPrefix =<< parsePrefix msg-      (command, unparsedParams) <- P.fromEither $ mapLeft NF $ findCommand handler rest-      ctx <- P.note NoCtx =<< buildContext msg prefix command unparsedParams-      P.fromEither . mapLeft (ERR ctx) =<< invokeCommand ctx (ctx ^. #command)-      pure ctx-    case err of-      Left (ERR ctx e) -> fire $ customEvt @"command-error" (ctx, e)-      Left (NF path)   -> fire $ customEvt @"command-not-found" path-      Left _           -> pure () -- "ignore if no prefix or if context couldn't be built"-      Right ctx        -> fire $ customEvt @"command-run" ctx-  pure (remove, handler, res)---buildCommands :: P.Member (P.Final IO) r-              => P.Sem (DSLState r) a-              -> P.Sem r (CommandHandler, a)-buildCommands =-  ((\(groups, (cmds, a)) -> (CommandHandler groups cmds, a)) <$>) .-  P.fixpointToFinal .-  P.runReader [] .-  P.runReader (const "This command or group has no help.") .-  P.runReader Nothing .-  runLocalWriter @(LH.HashMap S.Text Group) .-  runLocalWriter @(LH.HashMap S.Text Command)--buildContext :: BotC r => Message -> L.Text -> Command -> L.Text -> P.Sem r (Maybe Context)-buildContext msg prefix command unparsed = (rightToMaybe <$>) . P.runFail $ do-  guild <- join <$> getGuild `traverse` (msg ^. #guildID)-  let member = guild ^? _Just . #members . ix (coerceSnowflake $ getID @User msg)-  let gchan = guild ^? _Just . #channels . ix (coerceSnowflake $ getID @Channel msg)-  Just channel <- case gchan of-    Just chan -> pure . pure $ GuildChannel' chan-    _         -> DMChannel' <<$>> getDM (coerceSnowflake $ getID @Channel msg)-  Just user <- getUser $ getID msg--  pure $ Context msg guild member channel user command prefix unparsed--nextWord :: L.Text -> (L.Text, L.Text)-nextWord = L.break isSpace . L.stripStart--findCommand :: CommandHandler -> L.Text -> Either [L.Text] (Command, L.Text)-findCommand handler msg = goH $ nextWord msg-  where-    goH :: (L.Text, L.Text) -> Either [L.Text] (Command, L.Text)-    goH ("", _) = Left []-    goH (x, xs) = attachSoFar x-      (((, xs) <$> attachInitial (LH.lookup (L.toStrict x) (handler ^. #commands)))-       <> (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)))-       <> (attachInitial (LH.lookup (L.toStrict x) (g ^. #children)) >>= goG (nextWord xs)))--    attachInitial :: Maybe a -> Either [L.Text] a-    attachInitial (Just a) = Right a-    attachInitial Nothing = Left []--    attachSoFar :: L.Text -> Either [L.Text] a -> Either [L.Text] a-    attachSoFar cmd (Left xs) = Left (cmd:xs)-    attachSoFar _ r = r+  deriving ( Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric CommandHandler

@@ -0,0 +1,105 @@+-- | A default help command implementation+module Calamity.Commands.Help+    ( helpCommand'+    , helpCommand ) where++import           Calamity.Client.Types+import           Calamity.Commands.Check+import           Calamity.Commands.Command+import           Calamity.Commands.CommandUtils+import           Calamity.Commands.Context+import           Calamity.Commands.Dsl+import           Calamity.Commands.Group+import           Calamity.Commands.Handler+import           Calamity.Internal.LocalWriter+import           Calamity.Types.Tellable++import           Control.Applicative+import           Control.Lens hiding ( Context(..) )+import           Control.Monad++import qualified Data.HashMap.Lazy              as LH+import qualified Data.Text                      as S+import qualified Data.Text.Lazy                 as L++import qualified Polysemy                       as P+import qualified Polysemy.Fail                  as P+import qualified Polysemy.Reader                as P++data CommandOrGroup+  = Command' Command+  | Group' Group [S.Text]++helpCommandHelp :: Context -> L.Text+helpCommandHelp _ = "Show help for a command or group."++groupPath :: Group -> [S.Text]+groupPath grp = maybe [] groupPath (grp ^. #parent) ++ [grp ^. #name]++commandParams :: Command -> L.Text+commandParams Command { params } = L.fromStrict $ S.intercalate " " params++helpForCommand :: Context -> Command -> L.Text+helpForCommand ctx (cmd@Command { name, parent, help }) = "```\nUsage: " <> prefix' <> path' <> " " <> params' <> "\n\n" <> help ctx <> "\n```"+  where prefix' = ctx ^. #prefix+        path'   = L.fromStrict . S.intercalate " " $ maybe [] groupPath parent ++ [name]+        params' = commandParams cmd++fmtCommandWithParams :: Command -> L.Text+fmtCommandWithParams cmd@Command { name } = L.fromStrict name <> " " <> commandParams cmd++helpForGroup :: Context -> Group -> L.Text+helpForGroup ctx grp = "```\nGroup: " <> path' <> "\n\n" <> (grp ^. #help) ctx <> "\n" <> groupsMsg <> commandsMsg <> "\n```"+  where path' = L.fromStrict . S.intercalate " " $ groupPath grp+        groups = LH.keys $ grp ^. #children+        commands = LH.elems $ grp ^. #commands+        groupsMsg = if null groups then "" else "The following child groups exist:\n" <> L.fromStrict (S.unlines . map ("- " <>) $ groups)+        commandsMsg = if null commands then "" else "\nThe following child commands exist:\n" <> (L.unlines . map ("- " <>) . map fmtCommandWithParams $ commands)++rootHelp :: CommandHandler -> L.Text+rootHelp handler = "```\n" <> groupsMsg <> commandsMsg <> "\n```"+  where groups = LH.keys $ handler ^. #groups+        commands = LH.elems $ handler ^. #commands+        groupsMsg = if null groups then "" else "The following groups exist:\n" <> L.fromStrict (S.unlines . map ("- " <>) $ groups)+        commandsMsg = if null commands then "" else "\nThe following commands exist:\n" <> (L.unlines . map ("- " <>) . map fmtCommandWithParams $ commands)++-- TODO: process checks++helpCommandCallback :: BotC r => CommandHandler -> Context -> [S.Text] -> P.Sem (P.Fail ': r) ()+helpCommandCallback handler ctx path = do+  case findCommandOrGroup handler path of+    Just (Command' cmd@Command { name }) ->+      void $ tell @L.Text ctx $ "Help for command `" <> L.fromStrict name <> "`: \n" <> helpForCommand ctx cmd+    Just (Group' grp@Group { name } remainingPath) ->+      let failedMsg = if null remainingPath+            then ""+            else "No command or group with the path: `" <> L.fromStrict (S.intercalate " " path) <> "` exists for the group: `" <> L.fromStrict name <> "`\n"+      in void $ tell @L.Text ctx $ failedMsg <> "Help for group `" <> L.fromStrict name <> "`: \n" <> helpForGroup ctx grp+    Nothing -> let failedMsg = if null path+                     then ""+                     else "No command or group with the path: `" <> L.fromStrict (S.intercalate " " path) <> "` was found.\n"+               in void $ tell @L.Text ctx $ failedMsg <> rootHelp handler++helpCommand' :: BotC r => CommandHandler -> Maybe Group -> [Check] -> P.Sem r Command+helpCommand' handler parent checks = buildCommand @'[[S.Text]] "help" parent checks helpCommandHelp+  (helpCommandCallback handler)++helpCommand :: BotC r => P.Sem (DSLState r) Command+helpCommand = do+  handler <- P.ask @CommandHandler+  parent <- P.ask @(Maybe Group)+  checks <- P.ask @[Check]+  cmd <- raiseDSL $ helpCommand' handler parent checks+  ltell $ LH.singleton "help" cmd+  pure cmd++findCommandOrGroup :: CommandHandler -> [S.Text] -> Maybe CommandOrGroup+findCommandOrGroup handler path = go (handler ^. #commands, handler ^. #groups) path+  where go :: (LH.HashMap S.Text Command, LH.HashMap S.Text Group) -> [S.Text] -> Maybe CommandOrGroup+        go (commands, groups) (x : xs) =+          case LH.lookup x commands of+            Just cmd -> Just (Command' cmd)+            Nothing  -> case LH.lookup x groups of+              Just group -> go (group ^. #commands, group ^. #children) xs <|> Just (Group' group xs)+              Nothing    -> Nothing+        go _ [] = Nothing

@@ -1,27 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}---- | A Writer monad that supports local writing, reverse reader I guess?-module Calamity.Commands.LocalWriter-    ( LocalWriter(..)-    , ltell-    , llisten-    , runLocalWriter ) where--import qualified Polysemy       as P-import qualified Polysemy.State as P--data LocalWriter o m a where-  Ltell :: o -> LocalWriter o m ()-  Llisten :: m a -> LocalWriter o m (o, a)--P.makeSem ''LocalWriter--runLocalWriter :: Monoid o => P.Sem (LocalWriter o ': r) a -> P.Sem r (o, a)-runLocalWriter = P.runState mempty . P.reinterpretH-  (\case-     Ltell o   -> do-       P.modify' (<> o) >>= P.pureT-     Llisten m -> do-       mm <- P.runT m-       (o, fa) <- P.raise $ runLocalWriter mm-       pure $ fmap (o, ) fa)

@@ -3,8 +3,7 @@     ( Parser(..)     , Named     , KleeneConcat-    , ParserState(..)-    , SpannedError(..) ) where+    , runCommandParser ) where  import           Calamity.Cache.Eff import           Calamity.Commands.Context@@ -22,7 +21,6 @@ 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           GHC.Generics                  ( Generic )@@ -37,7 +35,7 @@ import           Text.Megaparsec.Char import           Text.Megaparsec.Error.Builder ( errFancy, fancy ) -data SpannedError = SpannedError Text !Int !Int+data SpannedError = SpannedError L.Text !Int !Int   deriving ( Show, Eq, Ord )  showTypeOf :: forall a. Typeable a => String@@ -45,21 +43,24 @@  data ParserState = ParserState   { off :: Int-  , msg :: Text+  , msg :: L.Text   }   deriving ( Show, Generic ) -type ParserEffs r = P.State ParserState ': P.Error (S.Text, Text) ': P.Reader Context ': r+type ParserEffs r = P.State ParserState ': P.Error (S.Text, L.Text) ': P.Reader Context ': r type ParserCtxE r = P.Reader Context ': r +runCommandParser :: Context -> L.Text -> P.Sem (ParserEffs r) a -> P.Sem r (Either (S.Text, L.Text) a)+runCommandParser ctx t = P.runReader ctx . P.runError . P.evalState (ParserState 0 t)+ class Typeable a => Parser (a :: Type) r where   type ParserResult a    type ParserResult a = a -  name :: S.Text-  default name :: S.Text-  name = ":" <> S.pack (showTypeOf @a)+  parserName :: S.Text+  default parserName :: S.Text+  parserName = ":" <> S.pack (showTypeOf @a)    parse :: P.Sem (ParserEffs r) (ParserResult a) @@ -68,14 +69,14 @@ 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+  parserName = (S.pack . symbolVal $ Proxy @s) <> parserName @a @r -  parse = mapE (_1 .~ name @(Named s a) @r) $ parse @a @r+  parse = mapE (_1 .~ parserName @(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 :: S.Text -> ParsecT SpannedError L.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)@@ -85,9 +86,12 @@       pure a     Left s  -> P.throw (n, L.pack $ errorBundlePretty s) -instance Parser Text r where-  parse = parseMP (name @Text) item+instance Parser L.Text r where+  parse = parseMP (parserName @L.Text) item +instance Parser S.Text r where+  parse = parseMP (parserName @S.Text) (L.toStrict <$> item)+ instance Parser a r => Parser (Maybe a) r where   type ParserResult (Maybe a) = Maybe (ParserResult a) @@ -98,7 +102,9 @@    parse = go []     where go :: [ParserResult a] -> P.Sem (ParserEffs r) [ParserResult a]-          go l = P.catch ((: []) <$> parse @a) (const $ pure []) >>= go . (l ++)+          go l = P.catch (Just <$> parse @a) (const $ pure Nothing) >>= \case+            Just a -> go $ l ++ [a]+            Nothing -> pure l  instance (Parser a r, Typeable a) => Parser (NonEmpty a) r where   type ParserResult (NonEmpty a) = NonEmpty (ParserResult a)@@ -115,29 +121,35 @@    parse = mconcat <$> parse @[a] -instance {-# OVERLAPS #-}Parser (KleeneConcat Text) r where-  type ParserResult (KleeneConcat Text) = ParserResult Text+instance {-# OVERLAPS #-}Parser (KleeneConcat L.Text) r where+  type ParserResult (KleeneConcat L.Text) = ParserResult L.Text    -- consume rest on text just takes everything remaining-  parse = parseMP (name @(KleeneConcat Text)) someSingle+  parse = parseMP (parserName @(KleeneConcat L.Text)) someSingle +instance {-# OVERLAPS #-}Parser (KleeneConcat S.Text) r where+  type ParserResult (KleeneConcat S.Text) = ParserResult S.Text++  -- consume rest on text just takes everything remaining+  parse = parseMP (parserName @(KleeneConcat S.Text)) (L.toStrict <$> someSingle)+ instance Typeable (Snowflake a) => Parser (Snowflake a) r where-  parse = parseMP (name @(Snowflake a)) snowflake+  parse = parseMP (parserName @(Snowflake a)) snowflake  instance {-# OVERLAPS #-}Parser (Snowflake User) r where-  parse = parseMP (name @(Snowflake User)) (try (ping "@") <|> snowflake)+  parse = parseMP (parserName @(Snowflake User)) (try (ping "@") <|> snowflake)  instance {-# OVERLAPS #-}Parser (Snowflake Member) r where-  parse = parseMP (name @(Snowflake Member)) (try (ping "@") <|> snowflake)+  parse = parseMP (parserName @(Snowflake Member)) (try (ping "@") <|> snowflake)  instance {-# OVERLAPS #-}Parser (Snowflake Channel) r where-  parse = parseMP (name @(Snowflake Channel)) (try (ping "#") <|> snowflake)+  parse = parseMP (parserName @(Snowflake Channel)) (try (ping "#") <|> snowflake)  instance {-# OVERLAPS #-}Parser (Snowflake Role) r where-  parse = parseMP (name @(Snowflake Role)) (try (ping "@&") <|> snowflake)+  parse = parseMP (parserName @(Snowflake Role)) (try (ping "@&") <|> snowflake)  instance {-# OVERLAPS #-}Parser (Snowflake Emoji) r where-  parse = parseMP (name @(Snowflake Emoji)) (try emoji <|> snowflake)+  parse = parseMP (parserName @(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@@ -148,7 +160,7 @@ --     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 :: (Monad m, Stream s) => ParsecT SpannedError s m a -> L.Text -> (a -> m (Maybe b)) -> ParsecT SpannedError s m b mapParserMaybeM m e f = do   offs <- getOffset   r <- m >>= lift . f@@ -158,14 +170,14 @@     _       -> parseError . errFancy offs . fancy . ErrorCustom $ SpannedError e offs offe  instance Parser Member r where-  parse = parseMP (name @Member) $ mapParserMaybeM (try (ping "@") <|> snowflake)+  parse = parseMP (parserName @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 = parseMP (name @User @r) $ mapParserMaybeM (try (ping "@") <|> snowflake)+  parse = parseMP (parserName @User @r) $ mapParserMaybeM (try (ping "@") <|> snowflake)           "Couldn't find a User with this id"           getUser @@ -178,7 +190,7 @@     pure (a, b)  instance Parser () r where-  parse = parseMP (name @()) space+  parse = parseMP (parserName @()) space  instance ShowErrorComponent SpannedError where   showErrorComponent (SpannedError t _ _) = L.unpack t@@ -187,16 +199,16 @@ 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 :: MonadParsec e L.Text m => L.Text -> m (Snowflake a) ping c = chunk ("<" <> c) *> optional (chunk "!") *> snowflake <* chunk ">" -ping' :: MonadParsec e Text m => m () -> m (Snowflake a)+ping' :: MonadParsec e L.Text m => m () -> m (Snowflake a) ping' m = chunk "<" *> m *> snowflake <* chunk ">" -snowflake :: MonadParsec e Text m => m (Snowflake a)+snowflake :: MonadParsec e L.Text m => m (Snowflake a) snowflake = (Snowflake . read) <$> some digitChar -emoji :: MonadParsec e Text m => m (Snowflake a)+emoji :: MonadParsec e L.Text m => m (Snowflake a) emoji = ping' (optional (chunk "a") *> between (chunk ":") (chunk ":") (void $ takeWhileP Nothing $ not . (== ':')))  trackOffsets :: MonadParsec e s m => m a -> m (a, Int)@@ -206,7 +218,7 @@   offe <- getOffset   pure (a, offe - offs) -item :: MonadParsec e Text m => m Text+item :: MonadParsec e L.Text m => m L.Text item = try quotedString <|> someNonWS  -- manySingle :: MonadParsec e s m => m (Tokens s)@@ -215,7 +227,7 @@ someSingle :: MonadParsec e s m => m (Tokens s) someSingle = takeWhile1P (Just "any character") (const True) -quotedString :: MonadParsec e Text m => m Text+quotedString :: MonadParsec e L.Text m => m L.Text quotedString = try (between (chunk "'") (chunk "'") (takeWhileP (Just "any character") $ not . (== '\''))) <|>                between (chunk "\"") (chunk "\"") (takeWhileP (Just "any character") $ not . (== '"')) 

@@ -0,0 +1,121 @@+{-# LANGUAGE RecursiveDo #-}+-- | Command handler utilities+module Calamity.Commands.Utils+    ( addCommands+    , buildCommands+    , buildContext ) where++import           Calamity.Cache.Eff+import           Calamity.Client.Client+import           Calamity.Client.Types+import           Calamity.Commands.Command+import           Calamity.Commands.CommandUtils+import           Calamity.Commands.Context+import           Calamity.Commands.Dsl+import           Calamity.Commands.Handler+import           Calamity.Commands.Error+import           Calamity.Commands.Group+import           Calamity.Commands.ParsePrefix+import           Calamity.Internal.LocalWriter+import           Calamity.Internal.Utils+import           Calamity.Types.Model.Channel+import           Calamity.Types.Model.User+import           Calamity.Types.Snowflake++import           Control.Lens                   hiding ( Context )+import           Control.Monad++import           Data.Char                      ( isSpace )+import qualified Data.HashMap.Lazy              as LH+import qualified Data.Text                      as S+import qualified Data.Text.Lazy                 as L++import qualified Polysemy                       as P+import qualified Polysemy.Error                 as P+import qualified Polysemy.Fail                  as P+import qualified Polysemy.Fixpoint              as P+import qualified Polysemy.Reader                as P++mapLeft :: (e -> e') -> Either e a -> Either e' a+mapLeft f (Left x)  = Left $ f x+mapLeft _ (Right x) = Right x++data FailReason+  = NoPrefix+  | NoCtx+  | NF [L.Text]+  | ERR Context CommandError++addCommands :: (BotC r, P.Member ParsePrefix r) => P.Sem (DSLState r) a -> P.Sem r (P.Sem r (), CommandHandler, a)+addCommands m = do+  (handler, res) <- buildCommands m+  remove <- react @'MessageCreateEvt $ \msg -> do+    err <- P.runError $ do+      (prefix, rest) <- P.note NoPrefix =<< parsePrefix msg+      (command, unparsedParams) <- P.fromEither $ mapLeft NF $ findCommand handler rest+      ctx <- P.note NoCtx =<< buildContext msg prefix command unparsedParams+      P.fromEither . mapLeft (ERR ctx) =<< invokeCommand ctx (ctx ^. #command)+      pure ctx+    case err of+      Left (ERR ctx e) -> fire $ customEvt @"command-error" (ctx, e)+      Left (NF path)   -> fire $ customEvt @"command-not-found" path+      Left _           -> pure () -- "ignore if no prefix or if context couldn't be built"+      Right ctx        -> fire $ customEvt @"command-run" ctx+  pure (remove, handler, res)+++buildCommands :: forall r a. P.Member (P.Final IO) r+              => P.Sem (DSLState r) a+              -> P.Sem r (CommandHandler, a)+buildCommands m = P.fixpointToFinal $ mdo+  (groups, (cmds, a)) <- inner handler m+  let handler = CommandHandler groups cmds+  pure (handler, a)++  where inner :: CommandHandler -> P.Sem (DSLState r) a -> P.Sem (P.Fixpoint ': r) (LH.HashMap S.Text Group, (LH.HashMap S.Text Command, a))+        inner h =+          P.runReader h .+          P.runReader [] .+          P.runReader (const "This command or group has no help.") .+          P.runReader Nothing .+          runLocalWriter @(LH.HashMap S.Text Group) .+          runLocalWriter @(LH.HashMap S.Text Command)+++buildContext :: BotC r => Message -> L.Text -> Command -> L.Text -> P.Sem r (Maybe Context)+buildContext msg prefix command unparsed = (rightToMaybe <$>) . P.runFail $ do+  guild <- join <$> getGuild `traverse` (msg ^. #guildID)+  let member = guild ^? _Just . #members . ix (coerceSnowflake $ getID @User msg)+  let gchan = guild ^? _Just . #channels . ix (coerceSnowflake $ getID @Channel msg)+  Just channel <- case gchan of+    Just chan -> pure . pure $ GuildChannel' chan+    _         -> DMChannel' <<$>> getDM (coerceSnowflake $ getID @Channel msg)+  Just user <- getUser $ getID msg++  pure $ Context msg guild member channel user command prefix unparsed++nextWord :: L.Text -> (L.Text, L.Text)+nextWord = L.break isSpace . L.stripStart++findCommand :: CommandHandler -> L.Text -> Either [L.Text] (Command, L.Text)+findCommand handler msg = goH $ nextWord msg+  where+    goH :: (L.Text, L.Text) -> Either [L.Text] (Command, L.Text)+    goH ("", _) = Left []+    goH (x, xs) = attachSoFar x+      (((, xs) <$> attachInitial (LH.lookup (L.toStrict x) (handler ^. #commands)))+       <> (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)))+       <> (attachInitial (LH.lookup (L.toStrict x) (g ^. #children)) >>= goG (nextWord xs)))++    attachInitial :: Maybe a -> Either [L.Text] a+    attachInitial (Just a) = Right a+    attachInitial Nothing = Left []++    attachSoFar :: L.Text -> Either [L.Text] a -> Either [L.Text] a+    attachSoFar cmd (Left xs) = Left (cmd:xs)+    attachSoFar _ r = r

@@ -0,0 +1,27 @@+{-# LANGUAGE TemplateHaskell #-}++-- | A Writer monad that supports local writing, reverse reader I guess?+module Calamity.Internal.LocalWriter+    ( LocalWriter(..)+    , ltell+    , llisten+    , runLocalWriter ) where++import qualified Polysemy       as P+import qualified Polysemy.State as P++data LocalWriter o m a where+  Ltell :: o -> LocalWriter o m ()+  Llisten :: m a -> LocalWriter o m (o, a)++P.makeSem ''LocalWriter++runLocalWriter :: Monoid o => P.Sem (LocalWriter o ': r) a -> P.Sem r (o, a)+runLocalWriter = P.runState mempty . P.reinterpretH+  (\case+     Ltell o   -> do+       P.modify' (<> o) >>= P.pureT+     Llisten m -> do+       mm <- P.runT m+       (o, fa) <- P.raise $ runLocalWriter mm+       pure $ fmap (o, ) fa)