diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for Calamity +## 0.1.19.0 + +* Support hidden commands. + ## 0.1.18.1 * Fix custom presences failing to parse. 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: a6769a4539e66514b12eecc23237ab16610680d4a5058078c778cbc99f1a47cb +-- hash: b7f7d022985218eb24907d49707d0f464e86155b7bf0f0f0b714e5052d475dcd name: calamity -version: 0.1.18.1 +version: 0.1.19.0 synopsis: A library for writing discord bots in haskell description: Please see the README on GitHub at category: Network, Web diff --git a/src/Calamity/Commands/Command.hs b/src/Calamity/Commands/Command.hs --- a/src/Calamity/Commands/Command.hs +++ b/src/Calamity/Commands/Command.hs @@ -23,7 +23,9 @@ data Command = forall a. Command { names :: NonEmpty S.Text , parent :: Maybe Group - , checks :: [Check] -- TODO check checks on default help + , hidden :: Bool + -- ^ If this command is hidden + , checks :: [Check] -- ^ A list of checks that must pass for this command to be invoked , params :: [S.Text] -- ^ A list of the parameters the command takes, only used for constructing @@ -43,14 +45,27 @@ , params :: [S.Text] , parent :: Maybe S.Text , checks :: [S.Text] + , hidden :: Bool } deriving ( Generic, Show ) deriving ( TextShow ) via TSG.FromGeneric CommandS instance Show Command where - showsPrec d Command { names, params, parent, checks } = showsPrec d $ CommandS names params (NE.head <$> parent ^? _Just . #names) - (checks ^.. traverse . #name) + showsPrec d Command {names, params, parent, checks, hidden} = + showsPrec d $ + CommandS + names + params + (NE.head <$> parent ^? _Just . #names) + (checks ^.. traverse . #name) + hidden instance TextShow Command where - showbPrec d Command { names, params, parent, checks } = showbPrec d $ CommandS names params (NE.head <$> parent ^? _Just . #names) - (checks ^.. traverse . #name) + showbPrec d Command {names, params, parent, checks, hidden} = + showbPrec d $ + CommandS + names + params + (NE.head <$> parent ^? _Just . #names) + (checks ^.. traverse . #name) + hidden 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 @@ -50,17 +50,26 @@ -- actions. buildCommand' :: P.Member (P.Final IO) r => NonEmpty S.Text + -- ^ The name (and aliases) of the command -> Maybe Group + -- ^ The parent group of the command + -> Bool + -- ^ If the command is hidden -> [Check] + -- ^ The checks for the command -> [S.Text] + -- ^ The names of the command's parameters -> (Context -> L.Text) + -- ^ The help generator for this command -> (Context -> P.Sem r (Either CommandError a)) + -- ^ The parser for this command -> ((Context, a) -> P.Sem (P.Fail ': r) ()) + -- ^ The callback for this command -> P.Sem r Command -buildCommand' names@(name :| _) parent checks params help parser cb = do +buildCommand' names@(name :| _) parent hidden checks params help parser cb = do cb' <- buildCallback cb parser' <- buildParser name parser - pure $ Command names parent checks params help parser' cb' + pure $ Command names parent hidden checks params help parser' cb' -- | Given the properties of a 'Command', a callback, and a type level list of -- the parameters, build a command by constructing a parser and wiring it up to @@ -81,14 +90,21 @@ buildCommand :: forall ps r. (P.Member (P.Final IO) r, TypedCommandC ps r) => NonEmpty S.Text + -- ^ The name (and aliases) of the command -> Maybe Group + -- ^ The parent group of the command + -> Bool + -- ^ If the command is hidden -> [Check] + -- ^ The checks for the command -> (Context -> L.Text) + -- ^ The help generator for this command -> (Context -> CommandForParsers ps r) + -- ^ The callback foor this command -> P.Sem r Command -buildCommand names parent checks help command = +buildCommand names parent hidden checks help command = let (parser, cb) = buildTypedCommand @ps command - in buildCommand' names parent checks (paramNames @ps @r) help parser cb + in buildCommand' names parent hidden checks (paramNames @ps @r) help parser cb -- | Given the name of the command the parser is for and a parser function in -- the 'P.Sem' monad, build a parser by transforming the Polysemy action into an diff --git a/src/Calamity/Commands/Dsl.hs b/src/Calamity/Commands/Dsl.hs --- a/src/Calamity/Commands/Dsl.hs +++ b/src/Calamity/Commands/Dsl.hs @@ -6,6 +6,7 @@ , command' , commandA , commandA' + , hide , help , requires , requires' @@ -43,6 +44,7 @@ ( LocalWriter (LH.HashMap S.Text (Command, AliasType)) ': LocalWriter (LH.HashMap S.Text (Group, AliasType)) ': P.Reader (Maybe Group) + ': P.Tagged "hidden" (P.Reader Bool) ': P.Reader (Context -> L.Text) ': P.Tagged "original-help" (P.Reader (Context -> L.Text)) ': P.Reader [Check] @@ -52,40 +54,52 @@ ) raiseDSL :: P.Sem r a -> P.Sem (DSLState r) a -raiseDSL = P.raise . P.raise . 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 . P.raise . P.raise -- | Given the command name and parameter names, @parser@ and @callback@ for a -- command in the 'P.Sem' monad, build a command by transforming the Polysemy -- actions into IO actions. Then register the command. -- --- The parent group, checks, and command help are drawn from the reader context. +-- The parent group, visibility, checks, and command help are drawn from the +-- reader context. command' :: P.Member (P.Final IO) r => S.Text + -- ^ The name of the command -> [S.Text] + -- ^ The names of the command's parameters -> (Context -> P.Sem r (Either CommandError a)) + -- ^ The parser for this command -> ((Context, a) -> P.Sem (P.Fail ': r) ()) + -- ^ The callback for this command -> P.Sem (DSLState r) Command command' name params parser cb = commandA' name [] params parser cb --- | Given the command name, aliases, and parameter names, @parser@ and @callback@ for a --- command in the 'P.Sem' monad, build a command by transforming the Polysemy --- actions into IO actions. Then register the command. +-- | Given the command name, aliases, and parameter names, @parser@ and +-- @callback@ for a command in the 'P.Sem' monad, build a command by +-- transforming the Polysemy actions into IO actions. Then register the command. -- --- The parent group, checks, and command help are drawn from the reader context. +-- The parent group, visibility, checks, and command help are drawn from the +-- reader context. commandA' :: P.Member (P.Final IO) r - => S.Text -- ^ name - -> [S.Text] -- ^ aliases - -> [S.Text] -- ^ parameter names + => S.Text + -- ^ The name of the command + -> [S.Text] + -- ^ The aliases for the command + -> [S.Text] + -- ^ The names of the command's parameters -> (Context -> P.Sem r (Either CommandError a)) + -- ^ The parser for this command -> ((Context, a) -> P.Sem (P.Fail ': r) ()) + -- ^ The callback for this command -> P.Sem (DSLState r) Command commandA' name aliases params parser cb = do parent <- P.ask @(Maybe Group) + hidden <- P.tag $ P.ask @Bool checks <- P.ask @[Check] help' <- P.ask @(Context -> L.Text) - cmd <- raiseDSL $ buildCommand' (name :| aliases) parent checks params help' parser cb + cmd <- raiseDSL $ buildCommand' (name :| aliases) parent hidden checks params help' parser cb ltell $ LH.singleton name (cmd, Original) ltell $ LH.fromList [(name, (cmd, Alias)) | name <- aliases] pure cmd @@ -93,6 +107,9 @@ -- | Given the name of a command and a callback, and a type level list of -- the parameters, build and register a command. -- +-- The parent group, visibility, checks, and command help are drawn from the +-- reader context. +-- -- ==== Examples -- -- Building a command that bans a user by id. @@ -110,13 +127,18 @@ ( P.Member (P.Final IO) r, TypedCommandC ps r) => S.Text + -- ^ The name of the command -> (Context -> CommandForParsers ps r) + -- ^ The callback for this command -> P.Sem (DSLState r) Command command name cmd = commandA @ps name [] cmd -- | Given the name and aliases of a command and a callback, and a type level list of -- the parameters, build and register a command. -- +-- The parent group, visibility, checks, and command help are drawn from the +-- reader context. +-- -- ==== Examples -- -- Building a command that bans a user by id. @@ -133,19 +155,30 @@ commandA :: forall ps r. ( P.Member (P.Final IO) r, TypedCommandC ps r) - => S.Text -- ^ name - -> [S.Text] -- ^ aliases + => S.Text + -- ^ The name of the command + -> [S.Text] + -- ^ The aliases for the command -> (Context -> CommandForParsers ps r) + -- ^ The callback for this command -> P.Sem (DSLState r) Command commandA name aliases cmd = do parent <- P.ask @(Maybe Group) + hidden <- P.tag $ P.ask @Bool checks <- P.ask @[Check] help' <- P.ask @(Context -> L.Text) - cmd' <- raiseDSL $ buildCommand @ps (name :| aliases) parent checks help' cmd + cmd' <- raiseDSL $ buildCommand @ps (name :| aliases) parent hidden checks help' cmd ltell $ LH.singleton name (cmd', Original) ltell $ LH.fromList [(name, (cmd', Alias)) | name <- aliases] pure cmd' +-- | Set the visibility of any groups or commands registered inside the given +-- action to hidden. +hide :: P.Member (P.Tagged "hidden" (P.Reader Bool)) r + => P.Sem r a + -> P.Sem r a +hide = P.tag @"hidden" . P.local @Bool (const True) . P.raise + -- | Set the help for any groups or commands registered inside the given action. help :: P.Member (P.Reader (Context -> L.Text)) r => (Context -> L.Text) @@ -162,9 +195,13 @@ -- | Construct a check and add it to the list of checks for any commands -- registered inside the given action. +-- +-- Refer to 'Calamity.Commands.Check.Check' for more info on checks. requires' :: P.Member (P.Final IO) r => S.Text + -- ^ The name of the check -> (Context -> P.Sem r (Maybe L.Text)) + -- ^ The callback for the check -> P.Sem (DSLState r) a -> P.Sem (DSLState r) a requires' name cb m = do @@ -173,7 +210,10 @@ -- | Construct some pure checks and add them to the list of checks for any -- commands registered inside the given action. +-- +-- Refer to 'Calamity.Commands.Check.Check' for more info on checks. requiresPure :: [(S.Text, Context -> Maybe L.Text)] + -- A list of check names and check callbacks -> P.Sem (DSLState r) a -> P.Sem (DSLState r) a requiresPure checks = requires $ map (uncurry buildCheckPure) checks @@ -184,27 +224,34 @@ -- This also resets the @help@ function back to it's original value, use -- 'group'' if you don't want that (i.e. your help function is context aware). group :: P.Member (P.Final IO) r - => S.Text - -> P.Sem (DSLState r) a - -> P.Sem (DSLState r) a + => S.Text + -- ^ The name of the group + -> P.Sem (DSLState r) a + -> P.Sem (DSLState r) a group name m = groupA name [] m --- | Construct a group with aliases and place any commands registered in the given action --- into the new group. +-- | Construct a group with aliases and place any commands registered in the +-- given action into the new group. -- +-- The parent group, visibility, checks, and command help are drawn from the +-- reader context. +-- -- This also resets the @help@ function back to it's original value, use -- 'group'' if you don't want that (i.e. your help function is context aware). groupA :: P.Member (P.Final IO) r - => S.Text -- ^ name - -> [S.Text] -- ^ aliases - -> P.Sem (DSLState r) a - -> P.Sem (DSLState r) a + => S.Text + -- ^ The name of the group + -> [S.Text] + -- ^ The aliases of the group + -> P.Sem (DSLState r) a + -> P.Sem (DSLState r) a groupA name aliases m = mdo parent <- P.ask @(Maybe Group) + hidden <- P.tag $ P.ask @Bool checks <- P.ask @[Check] help' <- P.ask @(Context -> L.Text) origHelp <- fetchOrigHelp - let group' = Group (name :| aliases) parent commands children help' checks + let group' = Group (name :| aliases) parent hidden commands children help' checks (children, (commands, res)) <- llisten @(LH.HashMap S.Text (Group, AliasType)) $ llisten @(LH.HashMap S.Text (Command, AliasType)) $ P.local @(Maybe Group) (const $ Just group') $ @@ -219,10 +266,14 @@ -- | Construct a group and place any commands registered in the given action -- into the new group. -- +-- The parent group, visibility, checks, and command help are drawn from the +-- reader context. +-- -- Unlike 'help' this doesn't reset the @help@ function back to it's original -- value. group' :: P.Member (P.Final IO) r - => S.Text -- ^ name + => S.Text + -- The name of the group -> P.Sem (DSLState r) a -> P.Sem (DSLState r) a group' name m = groupA' name [] m @@ -230,18 +281,24 @@ -- | Construct a group with aliases and place any commands registered in the given action -- into the new group. -- +-- The parent group, visibility, checks, and command help are drawn from the +-- reader context. +-- -- Unlike 'help' this doesn't reset the @help@ function back to it's original -- value. groupA' :: P.Member (P.Final IO) r - => S.Text -- ^ name - -> [S.Text] -- ^ aliases + => S.Text + -- ^ The name of the group + -> [S.Text] + -- ^ The aliases of the group -> P.Sem (DSLState r) a -> P.Sem (DSLState r) a groupA' name aliases m = mdo parent <- P.ask @(Maybe Group) + hidden <- P.tag $ P.ask @Bool checks <- P.ask @[Check] help' <- P.ask @(Context -> L.Text) - let group' = Group (name :| aliases) parent commands children help' checks + let group' = Group (name :| aliases) parent hidden commands children help' checks (children, (commands, res)) <- llisten @(LH.HashMap S.Text (Group, AliasType)) $ llisten @(LH.HashMap S.Text (Command, AliasType)) $ P.local @(Maybe Group) (const $ Just group') m diff --git a/src/Calamity/Commands/Group.hs b/src/Calamity/Commands/Group.hs --- a/src/Calamity/Commands/Group.hs +++ b/src/Calamity/Commands/Group.hs @@ -24,6 +24,7 @@ data Group = Group { names :: NonEmpty S.Text , parent :: Maybe Group + , hidden :: Bool , commands :: LH.HashMap S.Text (Command, AliasType) -- ^ Any child commands of this group , children :: LH.HashMap S.Text (Group, AliasType) @@ -31,7 +32,7 @@ , help :: Context -> L.Text -- ^ A function producing the \'help' for the group , checks :: [Check] - -- -- ^ A list of checks that must pass + -- ^ A list of checks that must pass } deriving ( Generic ) @@ -40,12 +41,13 @@ , parent :: Maybe S.Text , commands :: LH.HashMap S.Text (Command, AliasType) , children :: LH.HashMap S.Text (Group, AliasType) + , hidden :: Bool } deriving ( Generic, Show ) deriving ( TextShow ) via TSG.FromGeneric GroupS instance Show Group where - showsPrec d Group { names, parent, commands, children } = showsPrec d $ GroupS names (NE.head <$> parent ^? _Just . #names) commands children + showsPrec d Group {names, parent, commands, children, hidden} = showsPrec d $ GroupS names (NE.head <$> parent ^? _Just . #names) commands children hidden instance TextShow Group where - showbPrec d Group { names, parent, commands, children } = showbPrec d $ GroupS names (NE.head <$> parent ^? _Just . #names) commands children + showbPrec d Group {names, parent, commands, children, hidden} = showbPrec d $ GroupS names (NE.head <$> parent ^? _Just . #names) commands children hidden diff --git a/src/Calamity/Commands/Help.hs b/src/Calamity/Commands/Help.hs --- a/src/Calamity/Commands/Help.hs +++ b/src/Calamity/Commands/Help.hs @@ -22,6 +22,7 @@ import qualified Data.HashMap.Lazy as LH import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.List.NonEmpty as NE +import Data.Maybe ( catMaybes ) import qualified Data.Text as S import qualified Data.Text.Lazy as L @@ -65,6 +66,12 @@ where inner (_, Alias) = Nothing inner (a, Original) = Just a +onlyVisibleC :: [Command] -> [Command] +onlyVisibleC = catMaybes . map notHiddenC + +onlyVisibleG :: [Group] -> [Group] +onlyVisibleG = catMaybes . map notHiddenG + helpForGroup :: Context -> Group -> L.Text helpForGroup ctx grp = "```\nGroup: " <> path' <> "\n" <> aliasesFmt <> @@ -72,8 +79,8 @@ (grp ^. #help) ctx <> "\n" <> groupsMsg <> commandsMsg <> "\n```" where path' = L.fromStrict . S.unwords $ groupPath grp - groups = onlyOriginals . LH.elems $ grp ^. #children - commands = onlyOriginals . LH.elems $ grp ^. #commands + groups = onlyVisibleG . onlyOriginals . LH.elems $ grp ^. #children + commands = onlyVisibleC .onlyOriginals . LH.elems $ grp ^. #commands groupsFmt = map formatWithAliases (groups ^.. traverse . #names) groupsMsg = if null groups then "" else "The following child groups exist:\n" <> (L.unlines . map ("- " <>) $ groupsFmt) commandsMsg = if null commands then "" else "\nThe following child commands exist:\n" <> (L.unlines . map ("- " <>) . map fmtCommandWithParams $ commands) @@ -84,8 +91,8 @@ rootHelp :: CommandHandler -> L.Text rootHelp handler = "```\n" <> groupsMsg <> commandsMsg <> "\n```" - where groups = onlyOriginals . LH.elems $ handler ^. #groups - commands = onlyOriginals . LH.elems $ handler ^. #commands + where groups = onlyVisibleG . onlyOriginals . LH.elems $ handler ^. #groups + commands = onlyVisibleC . onlyOriginals . LH.elems $ handler ^. #commands groupsFmt = map formatWithAliases (groups ^.. traverse . #names) groupsMsg = if null groups then "" else "The following groups exist:\n" <> (L.unlines . map ("- " <>) $ groupsFmt) commandsMsg = if null commands then "" else "\nThe following commands exist:\n" <> (L.unlines . map ("- " <>) . map fmtCommandWithParams $ commands) @@ -109,7 +116,7 @@ -- construct a help command that will provide help for all the commands and -- groups in the passed 'CommandHandler'. helpCommand' :: BotC r => CommandHandler -> Maybe Group -> [Check] -> P.Sem r Command -helpCommand' handler parent checks = buildCommand @'[[S.Text]] ("help" :| []) parent checks helpCommandHelp +helpCommand' handler parent checks = buildCommand @'[[S.Text]] ("help" :| []) parent False checks helpCommandHelp (helpCommandCallback handler) -- | Create and register the default help command for all the commands @@ -123,6 +130,12 @@ ltell $ LH.singleton "help" (cmd, Original) pure cmd +notHiddenC :: Command -> Maybe Command +notHiddenC c@(Command { hidden }) = if hidden then Nothing else Just c + +notHiddenG :: Group -> Maybe Group +notHiddenG g@(Group { hidden }) = if hidden then Nothing else Just g + findCommandOrGroup :: CommandHandler -> [S.Text] -> Maybe CommandOrGroup findCommandOrGroup handler path = go (handler ^. #commands, handler ^. #groups) path where go :: (LH.HashMap S.Text (Command, AliasType), LH.HashMap S.Text (Group, AliasType)) @@ -130,8 +143,8 @@ -> 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 + Just (notHiddenC -> Just cmd, _) -> Just (Command' cmd) + _ -> case LH.lookup x groups of + Just (notHiddenG -> Just group, _) -> go (group ^. #commands, group ^. #children) xs <|> Just (Group' group xs) + _ -> Nothing go _ [] = Nothing diff --git a/src/Calamity/Commands/Utils.hs b/src/Calamity/Commands/Utils.hs --- a/src/Calamity/Commands/Utils.hs +++ b/src/Calamity/Commands/Utils.hs @@ -124,6 +124,7 @@ P.runReader [] . P.runReader defaultHelp . P.untag @"original-help" . P.runReader defaultHelp . + P.runReader False . P.untag @"hidden" . P.runReader Nothing . runLocalWriter @(LH.HashMap S.Text (Group, AliasType)) . runLocalWriter @(LH.HashMap S.Text (Command, AliasType))