calamity 0.1.18.1 → 0.1.19.0

raw patch · 8 files changed

+158/−50 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• calamity.cabal +2/−2
• src/Calamity/Commands/Command.hs +20/−5
• src/Calamity/Commands/CommandUtils.hs +20/−4
• src/Calamity/Commands/Dsl.hs +84/−27
• src/Calamity/Commands/Group.hs +5/−3
• src/Calamity/Commands/Help.hs +22/−9
• src/Calamity/Commands/Utils.hs +1/−0

@@ -1,5 +1,9 @@ # Changelog for Calamity +## 0.1.19.0++* Support hidden commands.+ ## 0.1.18.1  * Fix custom presences failing to parse.

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

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

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

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

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

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

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