calamity 0.1.8.1 → 0.1.9.0

raw patch · 22 files changed

+976/−67 lines, 22 filesdep +megaparsecPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: megaparsec

API changes (from Hackage documentation)

Files

• ChangeLog.md +10/−0
• README.md +37/−19
• calamity.cabal +16/−3
• src/Calamity/Client/Client.hs +54/−26
• src/Calamity/Client/Types.hs +16/−1
• src/Calamity/Commands.hs +14/−0
• src/Calamity/Commands/Check.hs +40/−0
• src/Calamity/Commands/Command.hs +43/−0
• src/Calamity/Commands/Command.hs-boot +11/−0
• src/Calamity/Commands/CommandUtils.hs +139/−0
• src/Calamity/Commands/Context.hs +34/−0
• src/Calamity/Commands/Context.hs-boot +10/−0
• src/Calamity/Commands/Dsl.hs +108/−0
• src/Calamity/Commands/Error.hs +21/−0
• src/Calamity/Commands/Group.hs +23/−0
• src/Calamity/Commands/Handler.hs +129/−0
• src/Calamity/Commands/LocalWriter.hs +27/−0
• src/Calamity/Commands/ParsePrefix.hs +24/−0
• src/Calamity/Commands/Parser.hs +154/−0
• src/Calamity/Internal/RunIntoIO.hs +12/−7
• src/Calamity/Internal/Utils.hs +36/−8
• src/Calamity/Types/Tellable.hs +18/−3

@@ -1,5 +1,15 @@ # Changelog for Calamity +## 0.1.9.0++*2020-05-22*++* Added commands, located in `Calamity.Commands`, along with a DSL for declaring+  commands nicely.+  +* Renamed `waitUntil` to `waitUntilM`, and introduced a variant with a pure+  check function that takes the original name of `waitUntil`.+ ## 0.1.8.0  *2020-05-15*

@@ -56,6 +56,8 @@  import           Calamity import           Calamity.Cache.InMemory+import           Calamity.Commands+import qualified Calamity.Commands.Context                  as CommandContext import           Calamity.Metrics.Noop  import           Control.Concurrent@@ -95,22 +97,45 @@     Left e -> DiP.error (e ^. packed)     _      -> pure () -info = DiP.info @Text-debug = DiP.info @Text+info, debug :: BotC r => Text -> P.Sem r ()+info = DiP.info+debug = DiP.info  tellt :: (BotC r, Tellable t) => t -> Text -> P.Sem r (Either RestError Message)-tellt = tell @Text+tellt t m = tell t $ L.toStrict m  main :: IO () main = do   token <- view packed <$> getEnv "BOT_TOKEN"-  void . P.runFinal . P.embedToFinal . runCounterAtomic . runCacheInMemory . runMetricsPrometheusIO+  void . P.runFinal . P.embedToFinal . runCounterAtomic . runCacheInMemory . runMetricsPrometheusIO . useConstantPrefix "!"     $ runBotIO (BotToken token) $ do+    addCommands $ do+      command @'[Text, Snowflake User] "test" $ \ctx something aUser -> do+        info $ "something = " <> showt something <> ", aUser = " <> showt aUser+      command @'[] "hello" $ \ctx -> do+        void $ tellt ctx "heya"+      group "testgroup" $ do+        command @'[[Text]] "test" $ \ctx l -> do+          void $ tellt ctx ("you sent: " <> showtl l)+        command @'[] "count" $ \ctx -> do+          val <- getCounter+          void $ tellt ctx ("The value is: " <> showtl val)+        group "say" $ do+          command @'[KleeneConcat Text] "this" $ \ctx msg -> do+            void $ tellt ctx msg+      command @'[] "explode" $ \ctx -> do+        Just x <- pure Nothing+        debug "unreachable!"+      command @'[] "bye" $ \ctx -> do+        void $ tellt ctx "bye!"+        stopBot+      command @'[] "fire-evt" $ \ctx -> do+        fire $ customEvt @"my-event" ("aha" :: Text, ctx ^. #message)+      command @'[Text] "wait-for" $ \ctx s -> do+        void $ tellt ctx ("waiting for !" <> s)+        waitUntil @'MessageCreateEvt (\msg -> msg ^. #content == ("!" <> s))+        void $ tellt ctx ("got !" <> s)     react @'MessageCreateEvt $ \msg -> handleFailByLogging $ case msg ^. #content of-      "!count" -> replicateM_ 3 $ do-        val <- getCounter-        info $ "the counter is: " <> showt val-        void $ tellt msg ("The value is: " <> showt val)       "!say hi" -> replicateM_ 3 . P.async $ do         info "saying heya"         Right msg' <- tellt msg "heya"@@ -119,18 +144,11 @@         info "slept"         void . invoke $ EditMessage (msg ^. #channelID) msg' (Just "lol") Nothing         info "edited"-      "!explode" -> do-        Just x <- pure Nothing-        debug "unreachable!"-      "!bye" -> do-        void $ tellt msg "bye!"-        stopBot-      "!fire-evt" -> fire $ customEvt @"my-event" ("aha" :: Text, msg)-      "!wait" -> do-        void $ tellt msg "waiting for !continue"-        waitUntil @'MessageCreateEvt (\msg -> (debug $ "got message: " <> showt msg) >> (pure $ msg ^. #content == "!continue"))-        void $ tellt msg "got !continue"       _ -> pure ()+    react @('CustomEvt "command-error" (CommandContext.Context, CommandError)) $ \(ctx, e) -> do+      info $ "Command failed with reason: " <> showt e+      case e of+        ParseError t r -> void . tellt ctx $ "Failed to parse parameter: " <> L.fromStrict t <> ", with reason: ```\n" <> r <> "```"     react @('CustomEvt "my-event" (Text, Message)) $ \(s, m) ->       void $ tellt m ("Somebody told me to tell you about: " <> s) ```

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 2763f995fb4b7a5e41a214cd6a7d841b9c99817d27924c59d216ff0271005b8b+-- hash: bcd0c50d2410522101e3729e6c1c6f0d6a5830f977929848fc4a7507d8af872b  name:           calamity-version:        0.1.8.1+version:        0.1.9.0 synopsis:       A library for writing discord bots description:    Please see the README on GitHub at <https://github.com/nitros12/calamity#readme> category:       Network, Web@@ -40,6 +40,18 @@       Calamity.Client.Client       Calamity.Client.ShardManager       Calamity.Client.Types+      Calamity.Commands+      Calamity.Commands.Check+      Calamity.Commands.Command+      Calamity.Commands.CommandUtils+      Calamity.Commands.Context+      Calamity.Commands.Dsl+      Calamity.Commands.Error+      Calamity.Commands.Group+      Calamity.Commands.Handler+      Calamity.Commands.LocalWriter+      Calamity.Commands.ParsePrefix+      Calamity.Commands.Parser       Calamity.Gateway       Calamity.Gateway.DispatchEvents       Calamity.Gateway.Shard@@ -111,7 +123,7 @@   hs-source-dirs:       src   default-extensions: CPP AllowAmbiguousTypes BlockArguments NoMonomorphismRestriction BangPatterns BinaryLiterals UndecidableInstances ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs DerivingVia DerivingStrategies GeneralizedNewtypeDeriving StandaloneDeriving DeriveAnyClass InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings OverloadedLabels PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables TupleSections TypeFamilies TypeSynonymInstances ViewPatterns DuplicateRecordFields TypeOperators TypeApplications RoleAnnotations-  ghc-options: -fplugin=Polysemy.Plugin -funbox-strict-fields -Wall+  ghc-options: -fplugin=Polysemy.Plugin -funbox-strict-fields -Wall -fno-warn-name-shadowing   build-depends:       aeson >=1.4 && <2     , async >=2.2 && <3@@ -135,6 +147,7 @@     , http-types >=0.12 && <0.13     , lens >=4.18 && <5     , lens-aeson >=1.1 && <2+    , megaparsec >=8 && <9     , mtl >=2.2 && <3     , polysemy >=1.3 && <2     , polysemy-plugin >=0.2 && <0.3

@@ -9,6 +9,7 @@     , events     , fire     , waitUntil+    , waitUntilM     , CalamityEvent(Dispatch, ShutDown)     , customEvt ) where @@ -19,9 +20,9 @@ import           Calamity.Gateway.Types import           Calamity.HTTP.Internal.Ratelimit import           Calamity.Internal.GenericCurry+import           Calamity.Internal.RunIntoIO import qualified Calamity.Internal.SnowflakeMap   as SM import           Calamity.Internal.Updateable-import           Calamity.Internal.RunIntoIO import           Calamity.Internal.Utils import           Calamity.Metrics.Eff import           Calamity.Types.Model.Channel@@ -34,7 +35,7 @@ import           Control.Concurrent.MVar import           Control.Concurrent.STM import           Control.Exception                ( SomeException )-import           Control.Lens+import           Control.Lens                     hiding ( (<.>) ) import           Control.Monad  import           Data.Default.Class@@ -98,11 +99,6 @@         Di.push "calamity-stop" finishUp         pure Nothing -ehToIO :: forall r p. P.Member (P.Final IO) r => (p -> P.Sem r ()) -> P.Sem r (p -> IO ())-ehToIO f = runIntoIOFinal go-  where go :: P.Sem (IntoIO p ': r) (p -> IO ())-        go = intoIO (P.raise . f)- -- | Register an event handler, returning an action that removes the event handler from the bot. -- -- Refer to 'EventType' for what events you can register, and 'EHType' for the@@ -136,10 +132,10 @@       => EHType s (P.Sem r) ()       -> P.Sem r (P.Sem r ()) react handler = do-  handler' <- ehToIO $ uncurryG handler+  handler' <- bindSemToIO $ uncurryG handler   ehidC <- P.asks (^. #ehidCounter)   id' <- P.embed $ atomicModifyIORef ehidC (\i -> (succ i, i))-  let handlers = makeEventHandlers (Proxy @s) id' (curryG handler')+  let handlers = makeEventHandlers (Proxy @s) id' (const () <.> curryG handler')   P.atomicModify (handlers <>)   pure $ removeHandler @s id' @@ -184,18 +180,20 @@   P.embed $ dupChan inc  -- | Wait until an event satisfying a condition happens, then returns it's--- parameters+-- parameters. --+-- The check function for this command is pure unlike 'waitUntilM'+-- -- This is what it would look like with @s ~ \''MessageCreateEvt'@: -- -- @--- 'waitUntil' :: ('Message' -> 'P.Sem' r 'Bool') -> 'P.Sem' r 'Message'+-- 'waitUntil' :: ('Message' -> 'Bool') -> 'P.Sem' r 'Message' -- @ -- -- And for @s ~ \''MessageUpdateEvt'@: -- -- @--- 'waitUntil' :: ('Message' -> 'Message' -> 'P.Sem' r 'Bool') -> 'P.Sem' r ('Message', 'Message')+-- 'waitUntil' :: ('Message' -> 'Message' -> 'Bool') -> 'P.Sem' r ('Message', 'Message') -- @ -- -- ==== Examples@@ -203,15 +201,55 @@ -- Waiting for a message containing the text \"hi\": -- -- @--- f = do msg \<\- 'waitUntil' @\''MessageCreateEvt' (\m -> 'pure' $ 'Data.Text.Lazy.isInfixOf' "hi" $ m ^. #content)+-- f = do msg \<\- 'waitUntil' @\''MessageCreateEvt' (\m -> 'Data.Text.Lazy.isInfixOf' "hi" $ m ^. #content) --        print $ msg ^. #content -- @ waitUntil+  :: forall (s :: EventType) r t eh check.+  ( BotC r, WaitUntilConstraints r s eh check t)+  => check+  -> P.Sem r t+waitUntil f = do+  result <- P.embed newEmptyMVar+  remove <- react @s (curryG $ checker result)+  res <- P.embed $ takeMVar result+  remove+  pure res+  where+    checker :: MVar t -> t -> P.Sem r ()+    checker result args = do+      when (uncurryG f args) $ do+        P.embed $ putMVar result args++-- | Wait until an event satisfying a condition happens, then returns it's+-- parameters+--+-- This is what it would look like with @s ~ \''MessageCreateEvt'@:+--+-- @+-- 'waitUntilM' :: ('Message' -> 'P.Sem' r 'Bool') -> 'P.Sem' r 'Message'+-- @+--+-- And for @s ~ \''MessageUpdateEvt'@:+--+-- @+-- 'waitUntilM' :: ('Message' -> 'Message' -> 'P.Sem' r 'Bool') -> 'P.Sem' r ('Message', 'Message')+-- @+--+-- ==== Examples+--+-- Waiting for a message containing the text \"hi\":+--+-- @+-- f = do msg \<\- 'waitUntilM' @\''MessageCreateEvt' (\m -> ('debug' $ "got message: " <> 'showt' msg) >> ('pure' $ 'Data.Text.Lazy.isInfixOf' "hi" $ m ^. #content))+--        print $ msg ^. #content+-- @+waitUntilM   :: forall (s :: EventType) r t eh ehB.-  ( BotC r, WaitUntilConstraints r s eh ehB t)+  ( BotC r, WaitUntilMConstraints r s eh ehB t)   => ehB   -> P.Sem r t-waitUntil f = do+waitUntilM f = do   result <- P.embed newEmptyMVar   remove <- react @s (curryG $ checker result)   res <- P.embed $ takeMVar result@@ -221,7 +259,6 @@     checker :: MVar t -> t -> P.Sem r ()     checker result args = do       res <- uncurryG f args-      debug $ "checker result: " +|| res ||+ ""       when res $ do         P.embed $ putMVar result args @@ -284,7 +321,7 @@   eventHandlers <- P.atomicGet   actions <- P.runFail $ do     cacheUpdateHisto <- registerHistogram "cache_update" mempty [10, 20..100]-    (time, res) <- timeA $ handleEvent' eventHandlers data'+    (time, res) <- timeA $ Di.reset $ handleEvent' eventHandlers data'     void $ observeHistogram time cacheUpdateHisto     pure res @@ -295,15 +332,6 @@       (time, _) <- timeA . catchAllLogging $ P.embed action       void $ observeHistogram time eventHandleHisto     Left err      -> debug $ "Failed handling actions for event: " +| err |+ ""---- NOTE: We have to be careful with how we run event handlers---       They're registered through `react` which ensures the value of `r` in the event handler---       is the same as the final value of `r`, but:---       because they're held inside a 'Dynamic' to prevent the value of `r` being recursive,---       we have to make sure that we don't accidentally try to execute the event handler inside a---       nested effect, ie: `P.runError $ {- Handle events here -}` since that will result the value of---       `r` where we handle events be: `(P.Error a ': r)`, which will make stuff explode when we unwrap the---       event handlers  handleEvent' :: BotC r               => EventHandlers

@@ -8,6 +8,7 @@     , SetupEff     , ReactConstraints     , WaitUntilConstraints+    , WaitUntilMConstraints     , EventHandlers(..)     , InsertEventHandler(..)     , RemoveEventHandler(..)@@ -84,7 +85,21 @@  -- | Some constraints that 'Calamity.Client.Client.waitUntil' needs to work. Don't -- worry about these since they are satisfied for any type @s@ can be-type WaitUntilConstraints r s eh ehB t =+type WaitUntilConstraints r s eh check t =+  ( InsertEventHandler s+  , RemoveEventHandler s+  , Uncurry eh+  , eh ~ EHType s (P.Sem r) ()+  , eh ~ Curried (t -> P.Sem r ())+  , Uncurry check+  , Uncurried check ~ (t -> Bool)+  , Curry (t -> IO ())+  , Curried (t -> IO ()) ~ EHType s IO ()+  )++-- | Some constraints that 'Calamity.Client.Client.waitUntilM' needs to work. Don't+-- worry about these since they are satisfied for any type @s@ can be+type WaitUntilMConstraints r s eh ehB t =   ( InsertEventHandler s   , RemoveEventHandler s   , Uncurry eh

@@ -0,0 +1,14 @@+-- | Calamity commands+-- This module only exports the DSL and core types for using commands+module Calamity.Commands+    ( module Calamity.Commands.Dsl+    , module Calamity.Commands.Error+    , module Calamity.Commands.Handler+    , module Calamity.Commands.ParsePrefix+    , module Calamity.Commands.Parser ) where++import           Calamity.Commands.Dsl+import           Calamity.Commands.Error+import           Calamity.Commands.Handler+import           Calamity.Commands.ParsePrefix+import           Calamity.Commands.Parser

@@ -0,0 +1,40 @@+-- | Command invokation preconditions+module Calamity.Commands.Check+    ( Check(..)+    , buildCheck+    , buildCheckPure+    , runCheck ) where++import {-# SOURCE #-} Calamity.Commands.Context+import           Calamity.Commands.Error+import           Calamity.Internal.RunIntoIO+import           Calamity.Internal.Utils++import           Control.Lens                hiding ( (<.>), Context )++import           Data.Generics.Labels        ()+import           Data.Maybe+import qualified Data.Text                   as S+import qualified Data.Text.Lazy              as L++import           GHC.Generics++import qualified Polysemy                    as P++data Check = MkCheck+  { name     :: S.Text+  , callback :: Context -> IO (Maybe L.Text)+  }+  deriving ( Generic )++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''++buildCheckPure :: S.Text -> (Context -> Maybe L.Text) -> Check+buildCheckPure name cb = MkCheck name (pure . cb)++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) <$>)

@@ -0,0 +1,43 @@+-- | Commands and stuff+module Calamity.Commands.Command+    ( Command(..) ) where++import           Calamity.Commands.Check+import           Calamity.Commands.Context+import           Calamity.Commands.Error+import           Calamity.Commands.Group++import           Control.Lens              hiding ( (<.>), Context )++import           Data.Text                 as S+import           Data.Text.Lazy            as L++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic          as TSG++data Command = forall a. Command+  { name     :: S.Text+  , parent   :: Maybe Group+  , checks   :: [Check]+  , help     :: Context -> L.Text+  , parser   :: Context -> IO (Either CommandError a)+  , callback :: (Context, a) -> IO (Maybe L.Text)+  }++data CommandS = CommandS+  { name   :: S.Text+  , parent :: Maybe S.Text+  , checks :: [S.Text]+  }+  deriving ( Generic, Show )+  deriving ( TextShow ) via TSG.FromGeneric CommandS++instance Show Command where+  showsPrec d Command { name, parent, checks } = showsPrec d $ CommandS name (parent ^? _Just . #name)+    (checks ^.. traverse . #name)++instance TextShow Command where+  showbPrec d Command { name, parent, checks } = showbPrec d $ CommandS name (parent ^? _Just . #name)+    (checks ^.. traverse . #name)

@@ -0,0 +1,11 @@+-- | Commands and stuff+module Calamity.Commands.Command+    ( Command+    ) where++import TextShow++data Command++instance Show Command+instance TextShow Command

@@ -0,0 +1,139 @@+-- | Command utilities+module Calamity.Commands.CommandUtils+    ( TypedCommandC+    , CommandForParsers+    , buildCommand+    , buildCommand'+    , buildParser+    , buildCallback+    , runCommand+    , invokeCommand ) where++import           Calamity.Commands.Check+import           Calamity.Commands.Command+import           Calamity.Commands.Context+import           Calamity.Commands.Error+import           Calamity.Commands.Group+import           Calamity.Commands.Parser+import           Calamity.Internal.RunIntoIO+import           Calamity.Internal.Utils++import           Control.Lens                hiding ( (<.>), Context )+import           Control.Monad++import           Data.Foldable+import           Data.Kind+import           Data.Maybe+import           Data.Text                   as S+import           Data.Text.Lazy              as L+import           Data.Typeable++import qualified Polysemy                    as P+import qualified Polysemy.Error              as P+import qualified Polysemy.Fail               as P++buildCommand' :: P.Member (P.Final IO) r+              => S.Text+              -> Maybe Group+              -> [Check]+              -> (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+  cb' <- buildCallback cb+  parser' <- buildParser name parser+  pure $ Command name parent checks help parser' cb'++buildCommand :: forall ps a r.+             (P.Member (P.Final IO) r, TypedCommandC ps a r)+             => S.Text+             -> Maybe Group+             -> [Check]+             -> (Context -> L.Text)+             -> (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++buildParser :: P.Member (P.Final IO) r+            => S.Text+            -> (Context -> P.Sem r (Either CommandError a))+            -> P.Sem r (Context -> IO (Either CommandError a))+buildParser cmdName cb = do+  cb' <- bindSemToIO cb+  let cb'' ctx = fromMaybe (Left $ ParseError ("Parser for command: " <> cmdName) "failed internally") <$> cb' ctx+  pure cb''++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+  cb' <- bindSemToIO (\x -> P.runFail (cb x) <&> \case+                        Left e -> Just $ L.pack e+                        _      -> Nothing)+  let cb'' = fromMaybe (Just "failed internally") <.> cb'+  pure cb''++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 <$>)++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)+  P.fromEither =<< runCommand ctx cmd++type CommandSemType r = P.Sem (P.Fail ': r) ()++type TypedCommandC ps a r =+  ( ApplyTupRes a (CommandSemType r) ~ CommandForParsers ps r+  , a ~ ParamsFromParsers ps+  , BuildTypedCommandParser ps r+  , ApplyTup a (CommandSemType r))++buildTypedCommand+  :: forall (ps :: [Type]) a r.+  TypedCommandC ps a r+  => (Context -> CommandForParsers ps r)+  -> ( Context+         -> P.Sem r (Either CommandError a)+     , (Context, a)+         -> P.Sem (P.Fail ': r) ())+buildTypedCommand cmd = let parser ctx = buildTypedCommandParser @ps (ctx, ctx ^. #unparsedParams)+                            consumer (ctx, r) = applyTup (cmd ctx) r+                        in (parser, consumer)++class ApplyTup a b where+  type ApplyTupRes a b++  applyTup :: ApplyTupRes a b -> a -> b++instance ApplyTup as b => ApplyTup (a, as) b where+  type ApplyTupRes (a, as) b = a -> ApplyTupRes as b++  applyTup f (a, as) = applyTup (f a) as++instance ApplyTup () b where+  type ApplyTupRes () b = b++  applyTup r () = r++class BuildTypedCommandParser (ps :: [Type]) r where+  buildTypedCommandParser :: (Context, L.Text) -> P.Sem r (Either CommandError (ParamsFromParsers ps))++instance BuildTypedCommandParser '[] r where+  buildTypedCommandParser (_, _) = pure $ Right ()++instance (Typeable x, Parser x r, BuildTypedCommandParser xs r) => BuildTypedCommandParser (x ': xs) r where+  buildTypedCommandParser (ctx, msg) = parse @x (ctx, msg) >>= \case+    Right (a, msg') -> (a, ) <<$>> buildTypedCommandParser @xs (ctx, msg')+    Left e          -> pure $ Left (ParseError (S.pack . show . typeRep $ Proxy @x) e)++type family ParamsFromParsers (ps :: [Type]) where+  ParamsFromParsers '[] = ()+  ParamsFromParsers (x ': xs) = (ParserResult x, ParamsFromParsers xs)++type family CommandForParsers (ps :: [Type]) r where+  CommandForParsers '[] r = P.Sem (P.Fail ': r) ()+  CommandForParsers (x ': xs) r = ParserResult x -> CommandForParsers xs r

@@ -0,0 +1,34 @@+-- | Command invokation context+module Calamity.Commands.Context+    ( Context(..) ) where++import {-# SOURCE #-} Calamity.Commands.Command+import           Calamity.Types.Model.Channel+import           Calamity.Types.Model.Guild+import           Calamity.Types.Model.User+import           Calamity.Types.Snowflake+import           Calamity.Types.Tellable++import qualified Data.Text.Lazy               as L++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic             as TSG++data Context = Context+  { message        :: Message+  , guild          :: Maybe Guild+  , member         :: Maybe Member+  , channel        :: Channel+  , user           :: User+  , command        :: Command+  , prefix         :: L.Text+  , unparsedParams :: L.Text+    -- ^ The message remaining after consuming the prefix+  }+  deriving ( Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric Context++instance Tellable Context where+  getChannel Context { channel } = pure . getID $ channel

@@ -0,0 +1,10 @@+-- | Command invokation context+module Calamity.Commands.Context+    ( Context ) where++import           TextShow++data Context++instance Show Context+instance TextShow Context

@@ -0,0 +1,108 @@+{-# LANGUAGE RecursiveDo #-}++-- | A DSL for generating commands and groups+module Calamity.Commands.Dsl+    ( command'+    , command+    , help+    , requires+    , requires'+    , requiresPure+    , group+    , DSLState+    , raiseDSL ) where++import           Calamity.Commands.Check+import           Calamity.Commands.Command     hiding ( help )+import           Calamity.Commands.CommandUtils+import           Calamity.Commands.Context     hiding ( command )+import           Calamity.Commands.Error+import           Calamity.Commands.Group       hiding ( help )+import           Calamity.Commands.LocalWriter++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.Fixpoint             as P+import qualified Polysemy.Reader               as P++type DSLState r = (LocalWriter (LH.HashMap S.Text Command) ':+                       LocalWriter (LH.HashMap S.Text Group) ':+                       P.Reader (Maybe Group) ':+                       P.Reader (Context -> L.Text) ':+                       P.Reader [Check] ':+                       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++-- | Build a command with an already prepared invokation action+command'+  :: P.Member (P.Final IO) r+  => 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+  parent <- P.ask @(Maybe Group)+  checks <- P.ask @[Check]+  help' <- P.ask @(Context -> L.Text)+  cmd <- raiseDSL $ buildCommand' name parent checks help' parser cb+  ltell $ LH.singleton name cmd+  pure cmd++command :: forall ps a r.+        ( P.Member (P.Final IO) r,+          TypedCommandC ps a r)+        => S.Text+        -> (Context -> CommandForParsers ps r)+        -> P.Sem (DSLState r) Command+command name cmd = do+  parent <- P.ask @(Maybe Group)+  checks <- P.ask @[Check]+  help' <- P.ask @(Context -> L.Text)+  cmd' <- raiseDSL $ buildCommand @ps name parent checks help' cmd+  ltell $ LH.singleton name cmd'+  pure cmd'++help :: P.Member (P.Reader (Context -> L.Text)) r+     => (Context -> L.Text)+     -> P.Sem r a+     -> P.Sem r a+help = P.local . const++requires :: [Check]+         -> P.Sem (DSLState r) a+         -> P.Sem (DSLState r) a+requires = P.local . (<>)++requires' :: P.Member (P.Final IO) r+          => S.Text+          -> (Context -> P.Sem r (Maybe L.Text))+          -> P.Sem (DSLState r) a+          -> P.Sem (DSLState r) a+requires' name cb m = do+  check <- raiseDSL $ buildCheck name cb+  requires [check] m++requiresPure :: [(S.Text, Context -> Maybe L.Text)]+             -> P.Sem (DSLState r) a+             -> P.Sem (DSLState r) a+requiresPure checks = requires $ map (uncurry buildCheckPure) checks++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 (const $ Just group') m+  ltell $ LH.singleton name group'+  pure res+

@@ -0,0 +1,21 @@+-- | Command errors+module Calamity.Commands.Error+    ( CommandError(..) ) where++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 CommandError+  = ParseError S.Text -- ^ The type of the parser+               L.Text -- ^ The reason that parsing failed+  | CheckError S.Text -- ^ The name of the check that failed+               L.Text -- ^ The reason for the check failing+  | InvokeError S.Text -- ^ The name of the command that failed+                L.Text -- ^ The reason for failing+  deriving ( Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric CommandError

@@ -0,0 +1,23 @@+-- | Command groups+module Calamity.Commands.Group+    ( Group(..) ) where++import           Calamity.Commands.Check+import {-# SOURCE #-} Calamity.Commands.Command+import {-# SOURCE #-} Calamity.Commands.Context++import qualified Data.HashMap.Lazy         as LH+import qualified Data.Text                 as S+import qualified Data.Text.Lazy            as L++import           GHC.Generics++data Group = Group+  { name     :: S.Text+  , parent   :: Maybe Group+  , commands :: LH.HashMap S.Text Command+  , children :: LH.HashMap S.Text Group+  , help     :: Context -> L.Text+  , checks   :: [Check]+  }+  deriving ( Generic )

@@ -0,0 +1,129 @@+-- | A command handler+module Calamity.Commands.Handler+    ( CommandHandler(..)+    , 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.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           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++data CommandHandler = CommandHandler+  { groups   :: LH.HashMap S.Text Group+    -- ^ Top level groups+  , 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++firstEither :: Either e a -> Either e a -> Either e a+firstEither (Right l) _ = Right l+firstEither l (Left _)  = l+firstEither _ r         = r++findCommand :: CommandHandler -> L.Text -> Either [L.Text] (Command, L.Text)+findCommand handler msg = goH $ nextWord msg+  where+    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)))+       `firstEither` (attachInitial (LH.lookup (L.toStrict x) (handler ^. #groups)) >>= goG (nextWord xs)))++    goG :: (L.Text, L.Text) -> Group -> Either [L.Text] (Command, L.Text)+    goG ("", _) _ = Left []+    goG (x, xs) g = attachSoFar x+      (((, xs) <$> attachInitial (LH.lookup (L.toStrict x) (g ^. #commands)))+       `firstEither` (attachInitial (LH.lookup (L.toStrict x) (g ^. #children)) >>= goG (nextWord xs)))++    attachInitial :: 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.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)

@@ -0,0 +1,24 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Command prefix parsing effect+module Calamity.Commands.ParsePrefix+    ( ParsePrefix(..)+    , parsePrefix+    , useConstantPrefix ) where++import           Calamity.Types.Model.Channel.Message++import           Control.Lens++import qualified Data.Text.Lazy                       as L++import qualified Polysemy                             as P++data ParsePrefix m a where+  ParsePrefix :: Message -> ParsePrefix m (Maybe (L.Text, L.Text))++P.makeSem ''ParsePrefix++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)))

@@ -0,0 +1,154 @@+-- | Something that can parse user input+module Calamity.Commands.Parser+    ( Parser(..)+    , KleeneConcat ) where++import           Calamity.Cache.Eff+import           Calamity.Commands.Context+import           Calamity.Internal.Utils+import           Calamity.Types.Model.Channel ( Channel )+import           Calamity.Types.Model.Guild   ( Emoji, Member, Role )+import           Calamity.Types.Model.User    ( User )+import           Calamity.Types.Snowflake++import           Control.Lens                 hiding ( Context )+import           Control.Monad++import           Data.Bifunctor+import           Data.Char                    ( isSpace )+import           Data.Kind+import           Data.List.NonEmpty           ( NonEmpty, nonEmpty )+import qualified Data.Text.Lazy               as L+import           Data.Text.Lazy               ( Text )+import           Data.Typeable++import qualified Polysemy                     as P++import           Text.Megaparsec              hiding ( parse )+import           Text.Megaparsec.Char++import           TextShow++class Parser (a :: Type) r where+  type ParserResult a++  type ParserResult a = a++  parse :: (Context, Text) -> P.Sem r (Either Text (ParserResult a, Text))++instance Parser Text r where+  parse (_ctx, msg) = pure $ runParserToCommandError item msg++instance Parser a r => Parser [a] r where+  type ParserResult [a] = [ParserResult a]++  parse (ctx, msg) = Right <$> go msg []+    where+      go :: Text -> [ParserResult a] -> P.Sem r ([ParserResult a], Text)+      go t l = parse @a (ctx, t) >>= \case+        Left _        -> pure (l, t)+        Right (v, t') -> go t' (l <> [v])++instance (Parser a r, Typeable a) => Parser (NonEmpty a) r where+  type ParserResult (NonEmpty a) = NonEmpty (ParserResult a)++  parse (ctx, msg) = parse @[a] (ctx, msg)+    <&> (\case+           Right (res, rest) -> case nonEmpty res of+             Just res' -> Right (res', rest)+             Nothing   -> Left ("Couldn't parse at least one of " <> (L.pack . show . typeRep $ Proxy @a))+           Left e            -> Left e)++data KleeneConcat a++instance (Monoid (ParserResult a), Parser a r) => Parser (KleeneConcat a) r where+  type ParserResult (KleeneConcat a) = ParserResult a++  parse (ctx, msg) = (first mconcat) <<$>> parse @[a] (ctx, msg)++instance {-# OVERLAPS #-}Parser (KleeneConcat Text) r where+  type ParserResult (KleeneConcat Text) = ParserResult Text++  -- consume rest on text just takes everything remaining+  parse (_ctx, msg) = pure $ runParserToCommandError (someSingle) msg++instance Parser (Snowflake a) r where+  parse (_ctx, msg) = pure $ runParserToCommandError snowflake msg++instance {-# OVERLAPS #-}Parser (Snowflake User) r where+  parse (_ctx, msg) = pure $ runParserToCommandError (try (ping "@") <|> snowflake) msg++instance {-# OVERLAPS #-}Parser (Snowflake Member) r where+  parse (_ctx, msg) = pure $ runParserToCommandError (try (ping "@") <|> snowflake) msg++instance {-# OVERLAPS #-}Parser (Snowflake Channel) r where+  parse (_ctx, msg) = pure $ runParserToCommandError (try (ping "#") <|> snowflake) msg++instance {-# OVERLAPS #-}Parser (Snowflake Role) r where+  parse (_ctx, msg) = pure $ runParserToCommandError (try (ping "@&") <|> snowflake) msg++instance {-# OVERLAPS #-}Parser (Snowflake Emoji) r where+  parse (_ctx, msg) = pure $runParserToCommandError+    (try emoji <|> snowflake) msg+++instance Parser Member r where+  parse (ctx, msg) = parse @(Snowflake Member) (ctx, msg)+    <&> (>>= \(mid, rest) -> case ctx ^? #guild . _Just . #members . ix mid of+           Just member -> Right (member, rest)+           _           -> Left ("Couldn't find member with id: " <> showtl mid))++instance P.Member CacheEff r => Parser User r where+  parse (ctx, msg) = do+    r <- parse @(Snowflake User) (ctx, msg)+    case r of+      Right (uid, rest) -> getUser uid <&> \case+        Just member -> Right (member, rest)+        _           -> Left ("Couldn't find user with id: " <> showtl uid)+      Left e            -> pure $ Left e++instance ShowErrorComponent Text where+  showErrorComponent = L.unpack+  errorComponentLen = fromIntegral . L.length++runParserToCommandError :: Parsec Text Text a -> Text -> Either Text (a, Text)+runParserToCommandError m t = case runParser (space *> andRemaining m) "" t of+  Right a -> Right a+  Left s  -> Left . L.pack . errorBundlePretty $ s++ping :: MonadParsec e Text m => Text -> m (Snowflake a)+ping c = chunk ("<" <> c) *> optional (chunk "!") *> snowflake <* chunk ">"++ping' :: MonadParsec e Text m => m () -> m (Snowflake a)+ping' m = chunk "<" *> m *> snowflake <* chunk ">"++snowflake :: MonadParsec e Text m => m (Snowflake a)+snowflake = (Snowflake . read) <$> some digitChar++emoji :: MonadParsec e Text m => m (Snowflake a)+emoji = ping' (optional (chunk "a") *> between (chunk ":") (chunk ":") (void $ takeWhileP Nothing $ not . (== ':')))++andRemaining :: MonadParsec e s m => m a -> m (a, Tokens s)+andRemaining m = do+  a <- m+  rest <- manySingle+  pure (a, rest)++item :: MonadParsec e Text m => m Text+item = try quotedString <|> someNonWS++manySingle :: MonadParsec e s m => m (Tokens s)+manySingle = takeWhileP (Just "Any character") (const True)++someSingle :: MonadParsec e s m => m (Tokens s)+someSingle = takeWhile1P (Just "Any character") (const True)++quotedString :: MonadParsec e Text m => m Text+quotedString = try (between (chunk "'") (chunk "'") (takeWhileP Nothing $ not . (== '\''))) <|>+               between (chunk "\"") (chunk "\"") (takeWhileP Nothing $ not . (== '"'))++-- manyNonWS :: (Token s ~ Char, MonadParsec e s m) => m (Tokens s)+-- manyNonWS = takeWhileP (Just "Any Non-Whitespace") (not . isSpace)++someNonWS :: (Token s ~ Char, MonadParsec e s m) => m (Tokens s)+someNonWS = takeWhile1P (Just "Any Non-Whitespace") (not . isSpace)

@@ -4,23 +4,28 @@ module Calamity.Internal.RunIntoIO     ( IntoIO(..)     , runIntoIOFinal-    , intoIO ) where--import           Control.Monad+    , intoIO+    , bindSemToIO ) where  import           Data.Functor  import qualified Polysemy                         as P import qualified Polysemy.Final                   as P -data IntoIO p m a where-  IntoIO :: (p -> m ()) -> IntoIO p m (p -> IO ())+data IntoIO p r m a where+  IntoIO :: (p -> m r) -> IntoIO p r m (p -> IO (Maybe r)) -runIntoIOFinal :: forall r p a. P.Member (P.Final IO) r => P.Sem (IntoIO p ': r) a -> P.Sem r a+runIntoIOFinal :: forall r p b a. P.Member (P.Final IO) r => P.Sem (IntoIO p b ': r) a -> P.Sem r a runIntoIOFinal = P.interpretFinal $ \case   IntoIO m -> do     istate <- P.getInitialStateS     m' <- P.bindS m-    P.liftS $ pure (\x -> void (m' $ istate $> x))+    ins <- P.getInspectorS+    P.liftS $ pure (\x -> P.inspect ins <$> m' (istate $> x))  P.makeSem ''IntoIO++bindSemToIO :: forall r p a. P.Member (P.Final IO) r => (p -> P.Sem r a) -> P.Sem r (p -> IO (Maybe a))+bindSemToIO f = runIntoIOFinal go+  where go :: P.Sem (IntoIO p a ': r) (p -> IO (Maybe a))+        go = intoIO (P.raise . f)

@@ -6,7 +6,12 @@     , whenM     , unlessM     , lastMaybe+    , leftToMaybe+    , rightToMaybe+    , justToEither     , (<<$>>)+    , (<<*>>)+    , (<.>)     , debug     , info     , Calamity.Internal.Utils.error@@ -14,18 +19,20 @@  import           Calamity.Types.LogEff +import           Control.Applicative+ import           Data.Default.Class-import qualified Data.HashMap.Lazy   as LH-import qualified Data.Map            as M-import           Data.Semigroup      ( Last(..) )+import qualified Data.HashMap.Lazy     as LH+import qualified Data.Map              as M+import           Data.Semigroup        ( Last(..) ) import           Data.Text.Lazy import           Data.Time-import qualified Data.Vector.Unboxed as VU-import           Data.Vector.Unboxed ( Vector )+import qualified Data.Vector.Unboxed   as VU+import           Data.Vector.Unboxed   ( Vector ) -import qualified DiPolysemy          as Di+import qualified DiPolysemy            as Di -import qualified Polysemy            as P+import qualified Polysemy              as P  import           TextShow @@ -43,11 +50,33 @@ lastMaybe :: Maybe a -> Maybe a -> Maybe a lastMaybe l r = getLast <$> fmap Last l <> fmap Last r +leftToMaybe :: Either e a -> Maybe e+leftToMaybe (Left x) = Just x+leftToMaybe _        = Nothing++rightToMaybe :: Either e a -> Maybe a+rightToMaybe (Right x) = Just x+rightToMaybe _         = Nothing++justToEither :: Maybe e -> Either e ()+justToEither (Just x) = Left x+justToEither _        = Right ()+ (<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) (<<$>>) = fmap . fmap  infixl 4 <<$>> +(<<*>>) :: (Applicative f, Applicative g) => f (g (a -> b)) -> f (g a) -> f (g b)+(<<*>>) = liftA2 (<*>)++infixl 4 <<*>>++(<.>) :: Functor f => (a -> b) -> (c -> f a) -> (c -> f b)+(<.>) f g x = f <$> g x++infixl 4 <.>+ debug :: P.Member LogEff r => Text -> P.Sem r () debug = Di.debug @@ -66,7 +95,6 @@ instance (TextShow a, VU.Unbox a) => TextShow (Vector a) where   showb = showbList . VU.toList -    -- lazy and strict use the same internal data structure instance (Show k, Show v) => TextShow (LH.HashMap k v) where   showb = fromString . show 

@@ -17,7 +17,8 @@ import           Data.ByteString.Lazy         ( ByteString ) import           Data.Default.Class import           Data.Monoid-import           Data.Text                    ( Text )+import qualified Data.Text                    as S+import qualified Data.Text.Lazy               as L  import           GHC.Generics @@ -33,16 +34,24 @@ -- Can be used to compose text, embeds, and files. /e.g./ -- -- @--- 'intoMsg' @'Text' "A message" '<>' 'intoMsg' @'Embed' ('def' '&' #description '?~' "Embed description")+-- 'intoMsg' @'L.Text' "A message" '<>' 'intoMsg' @'Embed' ('def' '&' #description '?~' "Embed description") -- @ class ToMessage a where   -- | Turn @a@ into a 'CreateMessageOptions' builder   intoMsg :: a -> Endo CreateMessageOptions  -- | Message content, '(<>)' concatenates the content-instance ToMessage Text where+instance ToMessage L.Text where+  intoMsg t = Endo (#content %~ (<> Just (L.toStrict t)))++-- | Message content, '(<>)' concatenates the content+instance ToMessage S.Text where   intoMsg t = Endo (#content %~ (<> Just t)) +-- | Message content, '(<>)' concatenates the content+instance ToMessage String where+  intoMsg t = Endo (#content %~ (<> Just (S.pack t)))+ -- | Message embed, '(<>)' merges embeds using '(<>)' instance ToMessage Embed where   intoMsg e = Endo (#embed %~ (<> Just e))@@ -85,6 +94,12 @@   P.fromEither r  instance Tellable DMChannel where+  getChannel = pure . getID++instance Tellable (Snowflake Channel) where+  getChannel = pure++instance Tellable Channel where   getChannel = pure . getID  instance Tellable (Snowflake DMChannel) where