calamity 0.1.9.2 → 0.1.9.3

raw patch · 15 files changed

+195/−17 lines, 15 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• README.md +5/−4
• calamity.cabal +2/−2
• src/Calamity/Client/Client.hs +1/−1
• src/Calamity/Commands.hs +34/−1
• src/Calamity/Commands/Check.hs +11/−0
• src/Calamity/Commands/Command.hs +10/−1
• src/Calamity/Commands/CommandUtils.hs +30/−0
• src/Calamity/Commands/Context.hs +8/−0
• src/Calamity/Commands/Dsl.hs +62/−3
• src/Calamity/Commands/Group.hs +5/−0
• src/Calamity/Commands/Help.hs +5/−0
• src/Calamity/Commands/ParsePrefix.hs +2/−0
• src/Calamity/Commands/Parser.hs +7/−2
• src/Calamity/Commands/Utils.hs +10/−1
• src/Calamity/Types/Snowflake.hs +3/−2

@@ -110,6 +110,11 @@   void . P.runFinal . P.embedToFinal . runCounterAtomic . runCacheInMemory . runMetricsPrometheusIO . useConstantPrefix "!"     $ runBotIO (BotToken token) $ do     addCommands $ do+      helpCommand+      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 @'[L.Text, Snowflake User] "test" $ \ctx something aUser -> do         info $ "something = " <> showt something <> ", aUser = " <> showt aUser       command @'[] "hello" $ \ctx -> do@@ -123,10 +128,6 @@         group "say" $ 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

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: ab08a364b5d3e67e015dfa8b1e5a96b8255ea898856a72811e1d1462bb984147+-- hash: f88c96cab00a86482d236a3a5f86d11d093b8179d8390725eabf46a12e054881  name:           calamity-version:        0.1.9.2+version:        0.1.9.3 synopsis:       A library for writing discord bots description:    Please see the README on GitHub at <https://github.com/nitros12/calamity#readme> category:       Network, Web

@@ -119,7 +119,7 @@ -- -- @ -- 'react' @(\''CustomEvt' "my-event" ('Data.Text.Text', 'Message')) $ \(s, m) ->---    'void' $ 'Calamity.Tellable.tell' @'Data.Text.Text' m ("Somebody told me to tell you about: " '<>' s)+--    'void' $ 'Calamity.Types.Tellable.tell' @'Data.Text.Text' m ("Somebody told me to tell you about: " '<>' s) -- @ -- -- ==== Notes

@@ -7,7 +7,10 @@     , module Calamity.Commands.Utils     , module Calamity.Commands.ParsePrefix     , module Calamity.Commands.Parser-    , module Calamity.Commands.Help ) where+    , module Calamity.Commands.Help+    -- * Commands+    -- $commandDocs+    ) where  import           Calamity.Commands.Dsl import           Calamity.Commands.Error@@ -16,3 +19,33 @@ import           Calamity.Commands.ParsePrefix import           Calamity.Commands.Parser import           Calamity.Commands.Utils++-- $commandDocs+--+-- This module provides abstractions for writing declarative commands, that+-- support grouping, pre-invokation checks, and automatic argument parsing by+-- using a type level list of parameter types.+--+-- A DSL is provided in 'Calamity.Commands.Dsl' for constructing commands+-- declaratively.+--+-- You can implement 'Parser' for your own types to allow them to be used in the+-- parameter list of commands.+--+-- A default help command is provided in 'Calamity.Commands.Help' which can be+-- added just by using 'helpCommand' inside the command declaration DSL.+--+-- ==== Examples+--+-- An example of using commands:+--+-- @+-- 'addCommands' $ do+--   'helpCommand'+--   'command' \@\'['Calamity.Types.Model.User.User'] "utest" $ \ctx u \-\> do+--     'Control.Monad.void' $ 'Calamity.Tellable.tell' ctx $ "got user: " '<>' 'TextShow.showtl' u+--   'group' "admin" $ do+--     'command' \@'[] "bye" $ \ctx -> do+--       'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' ctx "bye!"+--       'Calamity.Client.stopBot'+-- @

@@ -21,20 +21,31 @@  import qualified Polysemy                    as P +-- | A check for a command.+--+-- Every check for a command must return Nothing for the command to be run. data Check = MkCheck   { name     :: S.Text+    -- ^ The name of the check.   , callback :: Context -> IO (Maybe L.Text)+    -- ^ The callback for the check, returns Nothing if it passes, otherwise+    -- returns the reason for it not passing.   }   deriving ( Generic ) +-- | Given the name of a check and a callback in the 'P.Sem' monad, build a+-- check by transforming the Polysemy action into an IO action. buildCheck :: P.Member (P.Final IO) r => S.Text -> (Context -> P.Sem r (Maybe L.Text)) -> P.Sem r Check buildCheck name cb = do   cb' <- bindSemToIO cb   let cb'' = fromMaybe (Just "failed internally") <.> cb'   pure $ MkCheck name cb'' +-- | Given the name of a check and a pure callback function, build a check. buildCheckPure :: S.Text -> (Context -> Maybe L.Text) -> Check buildCheckPure name cb = MkCheck name (pure . cb) +-- | Given an invokation 'Context', run a check and transform the result into an+-- @'Either' 'CommandError' ()@. runCheck :: P.Member (P.Embed IO) r => Context -> Check -> P.Sem r (Either CommandError ()) runCheck ctx chk = P.embed (callback chk ctx) <&> justToEither . (CheckError (chk ^. #name) <$>)

@@ -17,14 +17,23 @@ import           TextShow import qualified TextShow.Generic          as TSG +-- | A command data Command = forall a. Command   { name     :: S.Text   , parent   :: Maybe Group-  , checks   :: [Check]+  , checks   :: [Check] -- TODO check checks on default help+    -- ^ 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+    -- help messages.   , help     :: Context -> L.Text+    -- ^ A function producing the \'help\' for the command.   , parser   :: Context -> IO (Either CommandError a)+    -- ^ A function that parses the context for the command, producing the input+    -- @a@ for the command.   , callback :: (Context, a) -> IO (Maybe L.Text)+    -- ^ A function that given the context and the input (@a@) of the command,+    -- performs the action of the command.   }  data CommandS = CommandS

@@ -31,6 +31,9 @@ import qualified Polysemy.Error              as P import qualified Polysemy.Fail               as P +-- | Given the properties of a 'Command' with the @parser@ and @callback@ in the+-- 'P.Sem' monad, build a command by transforming the Polysemy actions into IO+-- actions. buildCommand' :: P.Member (P.Final IO) r               => S.Text               -> Maybe Group@@ -45,6 +48,22 @@   parser' <- buildParser name parser   pure $ Command name parent 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+-- the callback.+--+-- ==== Examples+--+-- Building a command that bans a user by id.+--+-- @+-- 'buildCommand' @\'['Named' "user" ('Snowflake' 'User'), 'Named' "reason" ('KleeneConcat' 'S.Text')]+--    "ban" 'Nothing' [] ('const' "Ban a user") $ \ctx uid r -> case (ctx 'Control.Lens.^.' #guild) of+--      'Just' guild -> do+--        'void' . 'Calamity.HTTP.invoke' . 'Calamity.HTTP.reason' r $ 'Calamity.HTTP.Guild.CreateGuildBan' guild uid+--        'void' $ 'Calamity.Types.Tellable.tell' ctx ("Banned user `" '<>' 'TextShow.showt' uid '<>' "` with reason: " '<>' r)+--      'Nothing' -> 'void' $ 'Calamity.Types.Tellable.tell' @'L.Text' ctx "Can only ban users from guilds."+-- @ buildCommand :: forall ps r.              (P.Member (P.Final IO) r, TypedCommandC ps r)              => S.Text@@ -56,6 +75,9 @@ buildCommand name parent checks help command = let (parser, cb) = buildTypedCommand @ps command                                                in buildCommand' name parent 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+-- IO action. buildParser :: P.Member (P.Final IO) r             => S.Text             -> (Context -> P.Sem r (Either CommandError a))@@ -65,6 +87,8 @@   let cb'' ctx = fromMaybe (Left $ ParseError ("Parser for command: " <> name) "failed internally") <$> cb' ctx   pure cb'' +-- | Given a callback for a command in the 'P.Sem' monad, build a command callback by+-- transforming the Polysemy action into an IO action. buildCallback   :: P.Member (P.Final IO) r => ((Context, a) -> P.Sem (P.Fail ': r) ()) -> P.Sem r ((Context, a) -> IO (Maybe L.Text)) buildCallback cb = do@@ -74,11 +98,14 @@   let cb'' = fromMaybe (Just "failed internally") <.> cb'   pure cb'' +-- | Given an invokation 'Context', run a command. This does not perform the command's checks. runCommand :: P.Member (P.Embed IO) r => Context -> Command -> P.Sem r (Either CommandError ()) runCommand ctx Command { name, parser, callback } = P.embed (parser ctx) >>= \case   Left e   -> pure $ Left e   Right p' -> P.embed (callback (ctx, p')) <&> justToEither . (InvokeError name <$>) +-- | Given an invokation 'Context', first run all of the command's checks, then+-- run the command if they all pass. invokeCommand :: P.Member (P.Embed IO) r => Context -> Command -> P.Sem r (Either CommandError ()) invokeCommand ctx cmd@Command { checks } = P.runError $ do   for_ checks (P.fromEither <=< runCheck ctx)@@ -86,6 +113,7 @@  type CommandSemType r = P.Sem (P.Fail ': r) () +-- | Some constraints used for making parameter typed commands work type TypedCommandC ps r =   ( ApplyTupRes (ParserResult (ListToTup ps)) (CommandSemType r) ~ CommandForParsers ps r   , Parser (ListToTup ps) r@@ -138,6 +166,8 @@   ListToTup '[] = ()   ListToTup (x ': xs) = (x, ListToTup xs) +-- | Transform a type level list of types implementing the parser typeclass into+-- the type a command callback matching those parameters should be. type family CommandForParsers (ps :: [Type]) r where   CommandForParsers '[] r = P.Sem (P.Fail ': r) ()   CommandForParsers (x ': xs) r = ParserResult x -> CommandForParsers xs r

@@ -16,14 +16,22 @@ import           TextShow import qualified TextShow.Generic             as TSG +-- | Invokation context for commands data Context = Context   { message        :: Message+    -- ^ The message that the command was invoked from   , guild          :: Maybe Guild+    -- ^ If the command was sent in a guild, this will be present   , member         :: Maybe Member+    -- ^ The member that invoked the command, if in a guild   , channel        :: Channel+    -- ^ The channel the command was invoked from   , user           :: User+    -- ^ The user that invoked the command   , command        :: Command+    -- ^ The command that was invoked   , prefix         :: L.Text+    -- ^ The prefix that was used to invoke the command   , unparsedParams :: L.Text     -- ^ The message remaining after consuming the prefix   }

@@ -9,6 +9,7 @@     , requires'     , requiresPure     , group+    , group'     , DSLState     , raiseDSL ) where @@ -27,6 +28,7 @@  import qualified Polysemy                      as P import qualified Polysemy.Fail                 as P+import qualified Polysemy.Tagged               as P import qualified Polysemy.Fixpoint             as P import qualified Polysemy.Reader               as P @@ -34,14 +36,19 @@                        LocalWriter (LH.HashMap S.Text Group) ':                        P.Reader (Maybe Group) ':                        P.Reader (Context -> L.Text) ':+                       P.Tagged "original-help" (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 . P.raise+raiseDSL = P.raise . P.raise . P.raise . P.raise . P.raise . P.raise . P.raise . P.raise --- | Build a command with an already prepared invokation action+-- | 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. command'   :: P.Member (P.Final IO) r   => S.Text@@ -57,6 +64,22 @@   ltell $ LH.singleton name cmd   pure cmd +-- | Given the name of a command and a callback, and a type level list of+-- the parameters, build and register a command.+--+-- ==== Examples+--+-- Building a command that bans a user by id.+--+-- @+-- 'command' \@\'['Calamity.Commands.Parser.Named' "user" ('Calamity.Types.Snowflake' 'Calamity.Types.Model.User'),+--                'Calamity.Commands.Parser.Named' "reason" ('Calamity.Commands.Parser.KleeneConcat' 'S.Text')]+--    "ban" $ \ctx uid r -> case (ctx 'Control.Lens.^.' #guild) of+--      'Just' guild -> do+--        'Control.Monad.void' . 'Calamity.HTTP.invoke' . 'Calamity.HTTP.reason' r $ 'Calamity.HTTP.Guild.CreateGuildBan' guild uid+--        'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' ctx ("Banned user `" '<>' 'TextShow.showt' uid '<>' "` with reason: " '<>' r)+--      'Nothing' -> 'void' $ 'Calamity.Types.Tellable.tell' @'L.Text' ctx "Can only ban users from guilds."+-- @ command :: forall ps r.         ( P.Member (P.Final IO) r,           TypedCommandC ps r)@@ -71,17 +94,22 @@   ltell $ LH.singleton name cmd'   pure cmd' +-- | 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)      -> P.Sem r a      -> P.Sem r a help = P.local . const +-- | Add to the list of checks for any commands registered inside the given+-- action. requires :: [Check]          -> P.Sem (DSLState r) a          -> P.Sem (DSLState r) a requires = P.local . (<>) +-- | Construct a check and add it to the list of checks for any commands+-- registered inside the given action. requires' :: P.Member (P.Final IO) r           => S.Text           -> (Context -> P.Sem r (Maybe L.Text))@@ -91,11 +119,18 @@   check <- raiseDSL $ buildCheck name cb   requires [check] m +-- | Construct some pure checks and add them to the list of checks for any+-- commands registered inside the given action. requiresPure :: [(S.Text, Context -> Maybe L.Text)]              -> P.Sem (DSLState r) a              -> P.Sem (DSLState r) a requiresPure checks = requires $ map (uncurry buildCheckPure) checks +-- | Construct a group and place any commands registered in the given action+-- into the new group.+--+-- 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@@ -104,10 +139,34 @@   parent <- P.ask @(Maybe Group)   checks <- P.ask @[Check]   help'  <- P.ask @(Context -> L.Text)+  origHelp <- fetchOrigHelp   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 @(Maybe Group) (const $ Just group') m+                                 P.local @(Maybe Group) (const $ Just group') $+                                 P.local @(Context -> L.Text) (const origHelp) m   ltell $ LH.singleton name group'   pure res +fetchOrigHelp :: P.Member (P.Tagged "original-help" (P.Reader (Context -> L.Text))) r => P.Sem r (Context -> L.Text)+fetchOrigHelp = P.tag P.ask++-- | Construct a group and place any commands registered in the given action+-- into the new group.+--+-- Unlike 'help' this doesn't reset the @help@ function back to it's original+-- value.+group' :: P.Member (P.Final IO) r+         => S.Text+         -> P.Sem (DSLState r) a+         -> P.Sem (DSLState r) a+group' name m = mdo+  parent <- P.ask @(Maybe Group)+  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 @(Maybe Group) (const $ Just group') m+  ltell $ LH.singleton name group'+  pure res

@@ -17,13 +17,18 @@ import           TextShow import qualified TextShow.Generic          as TSG +-- | A group of commands data Group = Group   { name     :: S.Text   , parent   :: Maybe Group   , commands :: LH.HashMap S.Text Command+    -- ^ Any child commands of this group   , children :: LH.HashMap S.Text Group+    -- ^ Any child groups of this group   , help     :: Context -> L.Text+    -- ^ A function producing the \'help' for the group   , checks   :: [Check]+    -- -- ^ A list of checks that must pass   }   deriving ( Generic ) 

@@ -80,10 +80,15 @@                      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 +-- | Given a 'CommandHandler', optionally a parent 'Group', and a list of 'Check's,+-- 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   (helpCommandCallback handler) +-- | Create and register the default help command for all the commands+-- registered in the commands DSL this is used in. helpCommand :: BotC r => P.Sem (DSLState r) Command helpCommand = do   handler <- P.ask @CommandHandler

@@ -14,11 +14,13 @@  import qualified Polysemy                             as P +-- | An effect for parsing the prefix of a command. data ParsePrefix m a where   ParsePrefix :: Message -> ParsePrefix m (Maybe (L.Text, L.Text))  P.makeSem ''ParsePrefix +-- | A default interpretation for 'ParsePrefix' that uses a single constant prefix. useConstantPrefix :: L.Text -> P.Sem (ParsePrefix ': r) a -> P.Sem r a useConstantPrefix pre = P.interpret (\case                                        ParsePrefix m -> pure ((pre, ) <$> L.stripPrefix pre (m ^. #content)))

@@ -64,7 +64,9 @@    parse :: P.Sem (ParserEffs r) (ParserResult a) -data Named (s :: Symbol) a+-- | A named parameter, used to attach the name @s@ to a type in the command's+-- help output+data Named (s :: Symbol) (a :: Type)  instance (KnownSymbol s, Parser a r) => Parser (Named s a) r where   type ParserResult (Named s a) = ParserResult a@@ -114,7 +116,10 @@     as <- parse @[a]     pure $ a :| as -data KleeneConcat a+-- | A parser that consumes zero or more of @a@ then concatenates them together.+--+-- @'KleeneConcat' 'L.Text'@ Is therefore consumes all remaining input.+data KleeneConcat (a :: Type)  instance (Monoid (ParserResult a), Parser a r) => Parser (KleeneConcat a) r where   type ParserResult (KleeneConcat a) = ParserResult a

@@ -33,6 +33,7 @@ import qualified Polysemy                       as P import qualified Polysemy.Error                 as P import qualified Polysemy.Fail                  as P+import qualified Polysemy.Tagged                as P import qualified Polysemy.Fixpoint              as P import qualified Polysemy.Reader                as P @@ -46,6 +47,10 @@   | NF [L.Text]   | ERR Context CommandError +-- | Construct commands and groups from a command DSL, then registers an event+-- handler on the bot that manages running those commands.+--+-- Returns an action to remove the event handler, and the 'CommandHandler' that was constructed 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@@ -64,6 +69,7 @@   pure (remove, handler, res)  +-- | Run a command DSL, returning the constructed 'CommandHandler' buildCommands :: forall r a. P.Member (P.Final IO) r               => P.Sem (DSLState r) a               -> P.Sem r (CommandHandler, a)@@ -76,12 +82,15 @@         inner h =           P.runReader h .           P.runReader [] .-          P.runReader (const "This command or group has no help.") .+          P.runReader defaultHelp . P.untag @"original-help" .+          P.runReader defaultHelp .           P.runReader Nothing .           runLocalWriter @(LH.HashMap S.Text Group) .           runLocalWriter @(LH.HashMap S.Text Command)+        defaultHelp = (const "This command or group has no help.")  +-- | Attempt to build the context for a 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)

@@ -16,6 +16,7 @@ import           Data.Data import           Data.Generics.Product.Fields import           Data.Hashable+import           Data.Kind import           Data.Text.Read import qualified Data.Vector.Generic.Base     as V import qualified Data.Vector.Generic.Mutable  as MV@@ -25,11 +26,11 @@ import           GHC.Generics  import           TextShow-import qualified TextShow.Generic as TSG+import qualified TextShow.Generic             as TSG  -- Thanks sbrg -- https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hs#L78-newtype Snowflake t = Snowflake+newtype Snowflake (t :: Type) = Snowflake   { fromSnowflake :: Word64   }   deriving ( Generic, Show, Eq, Ord, Data )