calamity 0.10.0.0 → 0.11.0.0

raw patch · 38 files changed

+616/−396 lines, 38 filesdep ~aesondep ~bytestringdep ~containersPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, bytestring, containers, http-api-data, text, time, tls, websockets

API changes (from Hackage documentation)

Files

• Calamity/Cache/Eff.hs +5/−5
• Calamity/Cache/InMemory.hs +5/−4
• Calamity/Client/Client.hs +29/−21
• Calamity/Client/ShardManager.hs +3/−1
• Calamity/Client/Types.hs +1/−1
• Calamity/Commands/CalamityParsers.hs +10/−9
• Calamity/Commands/Context.hs +3/−3
• Calamity/Commands/Dsl.hs +7/−5
• Calamity/Gateway/DispatchEvents.hs +3/−3
• Calamity/Gateway/Shard.hs +14/−12
• Calamity/HTTP/AuditLog.hs +1/−1
• Calamity/HTTP/Channel.hs +118/−66
• Calamity/HTTP/Guild.hs +130/−84
• Calamity/HTTP/Interaction.hs +47/−20
• Calamity/HTTP/Internal/Ratelimit.hs +34/−31
• Calamity/HTTP/Internal/Request.hs +10/−8
• Calamity/HTTP/Internal/Route.hs +6/−6
• Calamity/HTTP/Internal/Types.hs +3/−3
• Calamity/HTTP/Reason.hs +2/−2
• Calamity/HTTP/User.hs +3/−3
• Calamity/HTTP/Webhook.hs +40/−27
• Calamity/Interactions/Eff.hs +4/−4
• Calamity/Interactions/Utils.hs +7/−5
• Calamity/Interactions/View.hs +8/−7
• Calamity/Internal/BoundedStore.hs +5/−4
• Calamity/Internal/ConstructorName.hs +2/−2
• Calamity/Internal/LocalWriter.hs +1/−1
• Calamity/Internal/RunIntoIO.hs +2/−2
• Calamity/Internal/SnowflakeMap.hs +7/−7
• Calamity/Internal/Utils.hs +27/−12
• Calamity/Types/CDNAsset.hs +2/−0
• Calamity/Types/Model/Channel/Attachment.hs +1/−1
• Calamity/Types/Model/Channel/Embed.hs +54/−16
• Calamity/Types/Tellable.hs +1/−1
• Calamity/Types/Upgradeable.hs +3/−3
• Calamity/Utils/Message.hs +1/−1
• ChangeLog.md +5/−0
• calamity.cabal +12/−15

@@ -102,17 +102,17 @@  makeSem ''CacheEff -updateBotUser :: P.Member CacheEff r => (User -> User) -> Sem r ()+updateBotUser :: (P.Member CacheEff r) => (User -> User) -> Sem r () updateBotUser f = getBotUser >>= flip whenJust (setBotUser . f) -updateGuild :: P.Member CacheEff r => Snowflake Guild -> (Guild -> Guild) -> Sem r ()+updateGuild :: (P.Member CacheEff r) => Snowflake Guild -> (Guild -> Guild) -> Sem r () updateGuild id f = getGuild id >>= flip whenJust (setGuild . f) -updateDM :: P.Member CacheEff r => Snowflake DMChannel -> (DMChannel -> DMChannel) -> Sem r ()+updateDM :: (P.Member CacheEff r) => Snowflake DMChannel -> (DMChannel -> DMChannel) -> Sem r () updateDM id f = getDM id >>= flip whenJust (setDM . f) -updateUser :: P.Member CacheEff r => Snowflake User -> (User -> User) -> Sem r ()+updateUser :: (P.Member CacheEff r) => Snowflake User -> (User -> User) -> Sem r () updateUser id f = getUser id >>= flip whenJust (setUser . f) -updateMessage :: P.Member CacheEff r => Snowflake Message -> (Message -> Message) -> Sem r ()+updateMessage :: (P.Member CacheEff r) => Snowflake Message -> (Message -> Message) -> Sem r () updateMessage id f = getMessage id >>= flip whenJust (setMessage . f)

@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-}+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}  -- | A 'Cache' handler that operates in memory module Calamity.Cache.InMemory (@@ -53,19 +54,19 @@ emptyCache' msgLimit = Cache Nothing SM.empty SM.empty SH.empty SM.empty HS.empty (Identity $ BS.empty msgLimit)  -- | Run the cache in memory with a default message cache size of 1000-runCacheInMemory :: P.Member (P.Embed IO) r => P.Sem (CacheEff ': r) a -> P.Sem r a+runCacheInMemory :: (P.Member (P.Embed IO) r) => P.Sem (CacheEff ': r) a -> P.Sem r a runCacheInMemory m = do   var <- P.embed $ newIORef emptyCache   P.runAtomicStateIORef var $ P.reinterpret runCache' m  -- | Run the cache in memory with no messages being cached-runCacheInMemoryNoMsg :: P.Member (P.Embed IO) r => P.Sem (CacheEff ': r) a -> P.Sem r a+runCacheInMemoryNoMsg :: (P.Member (P.Embed IO) r) => P.Sem (CacheEff ': r) a -> P.Sem r a runCacheInMemoryNoMsg m = do   var <- P.embed $ newIORef emptyCacheNoMsg   P.runAtomicStateIORef var $ P.reinterpret runCache' m  -- | Run the cache in memory with a configurable message cache limit-runCacheInMemory' :: P.Member (P.Embed IO) r => Int -> P.Sem (CacheEff ': r) a -> P.Sem r a+runCacheInMemory' :: (P.Member (P.Embed IO) r) => Int -> P.Sem (CacheEff ': r) a -> P.Sem r a runCacheInMemory' msgLimit m = do   var <- P.embed $ newIORef (emptyCache' msgLimit)   P.runAtomicStateIORef var $ P.reinterpret runCache' m@@ -91,7 +92,7 @@   getMessages' = pure []   delMessage' !_ = pure () -runCache :: MessageMod (Cache t) => CacheEff m a -> State (Cache t) a+runCache :: (MessageMod (Cache t)) => CacheEff m a -> State (Cache t) a runCache (SetBotUser u) = #user ?= u runCache GetBotUser = use #user runCache (SetGuild g) = do

@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}  -- | The client module Calamity.Client.Client (@@ -65,7 +66,7 @@ import Polysemy.Resource qualified as P import TextShow (TextShow (showt)) -timeA :: P.Member (P.Embed IO) r => P.Sem r a -> P.Sem r (Double, a)+timeA :: (P.Member (P.Embed IO) r) => P.Sem r a -> P.Sem r (Double, a) timeA m = do   start <- P.embed getPOSIXTime   res <- m@@ -103,19 +104,19 @@   P.Sem r (Maybe StartupError) runBotIO token intents = runBotIO' token intents Nothing -resetDi :: BotC r => P.Sem r a -> P.Sem r a+resetDi :: (BotC r) => P.Sem r a -> P.Sem r a resetDi m = do   initialDi <- P.asks (^. #initialDi)   Di.local (`fromMaybe` initialDi) m -interpretRatelimitViaClient :: P.Member (P.Reader Client) r => P.Sem (RatelimitEff ': r) a -> P.Sem r a+interpretRatelimitViaClient :: (P.Member (P.Reader Client) r) => P.Sem (RatelimitEff ': r) a -> P.Sem r a interpretRatelimitViaClient =   P.interpret     ( \case         GetRatelimitState -> P.asks (^. #rlState)     ) -interpretTokenViaClient :: P.Member (P.Reader Client) r => P.Sem (TokenEff ': r) a -> P.Sem r a+interpretTokenViaClient :: (P.Member (P.Reader Client) r) => P.Sem (TokenEff ': r) a -> P.Sem r a interpretTokenViaClient =   P.interpret     ( \case@@ -246,7 +247,7 @@  'fire' '$' 'customEvt' @"my-event" ("aha" :: 'Data.Text.Text', msg)  @ -}-fire :: BotC r => CalamityEvent -> P.Sem r ()+fire :: (BotC r) => CalamityEvent -> P.Sem r () fire e = do   inc <- P.asks (^. #eventsIn)   P.embed $ writeChan inc e@@ -261,11 +262,11 @@  'customEvt' (MyCustomEvent "lol")  @ -}-customEvt :: forall a. Typeable a => a -> CalamityEvent+customEvt :: forall a. (Typeable a) => a -> CalamityEvent customEvt = Custom  -- | Get a copy of the event stream.-events :: BotC r => P.Sem r (OutChan CalamityEvent)+events :: (BotC r) => P.Sem r (OutChan CalamityEvent) events = do   inc <- P.asks (^. #eventsIn)   P.embed $ dupChan inc@@ -356,20 +357,20 @@         P.embed $ putMVar result args  -- | Set the bot's presence on all shards.-sendPresence :: BotC r => StatusUpdateData -> P.Sem r ()+sendPresence :: (BotC r) => StatusUpdateData -> P.Sem r () sendPresence s = do   shards <- P.asks (^. #shards) >>= P.embed . readTVarIO   for_ shards $ \(inc, _) ->     P.embed $ writeChan inc (SendPresence s)  -- | Initiate shutting down the bot.-stopBot :: BotC r => P.Sem r ()+stopBot :: (BotC r) => P.Sem r () stopBot = do   debug "stopping bot"   inc <- P.asks (^. #eventsIn)   P.embed $ writeChan inc ShutDown -finishUp :: BotC r => P.Sem r ()+finishUp :: (BotC r) => P.Sem r () finishUp = do   debug "finishing up"   shards <- P.asks (^. #shards) >>= P.embed . readTVarIO@@ -381,7 +382,7 @@ {- | main loop of the client, handles fetching the next event, processing the  event and invoking its handler functions -}-clientLoop :: BotC r => P.Sem r ()+clientLoop :: (BotC r) => P.Sem r () clientLoop = do   outc <- P.asks (^. #eventsOut)   whileMFinalIO $ do@@ -400,14 +401,14 @@    for_ handlers (\h -> P.async . P.embed $ h d) -catchAllLogging :: BotC r => P.Sem r () -> P.Sem r ()+catchAllLogging :: (BotC r) => P.Sem r () -> P.Sem r () catchAllLogging m = do   r <- P.errorToIOFinal . P.fromExceptionSem @SomeException $ P.raise m   case r of     Right _ -> pure ()     Left e -> debug . T.pack $ "got exception: " <> show e -handleEvent :: BotC r => Int -> DispatchData -> P.Sem r ()+handleEvent :: (BotC r) => Int -> DispatchData -> P.Sem r () handleEvent shardID data' = do   debug . T.pack $ "handling an event: " <> ctorName data'   eventHandlers <- P.atomicGet@@ -429,7 +430,7 @@     Left err -> debug . T.pack $ "Failed handling actions for event: " <> show err  handleEvent' ::-  BotC r =>+  (BotC r) =>   EventHandlers ->   DispatchData ->   P.Sem (P.Fail ': r) [IO ()]@@ -667,7 +668,7 @@   pure [] handleEvent' _ e = fail $ "Unhandled event: " <> show e -updateCache :: P.Members '[CacheEff, P.Fail] r => DispatchData -> P.Sem r ()+updateCache :: (P.Members '[CacheEff, P.Fail] r) => DispatchData -> P.Sem r () updateCache (Ready ReadyData {user, guilds}) = do   setBotUser user   for_ (map getID guilds) setUnavailableGuild@@ -738,8 +739,11 @@     (getID reaction)     ( \m ->         m-          & #reactions % traversed %~ updateReactionRemove isMe (reaction ^. #emoji)-          & #reactions %~ filter (\r -> r ^. #count /= 0)+          & #reactions+          % traversed+          %~ updateReactionRemove isMe (reaction ^. #emoji)+          & #reactions+          %~ filter (\r -> r ^. #count /= 0)     ) updateCache (MessageReactionRemoveAll MessageReactionRemoveAllData {messageID}) =   updateMessage messageID (#reactions .~ mempty)@@ -780,8 +784,10 @@   if emoji == reaction ^. #emoji     then       reaction-        & #count %~ succ-        & #me %~ (|| isMe)+        & #count+        %~ succ+        & #me+        %~ (|| isMe)     else reaction  updateReactionRemove :: Bool -> RawEmoji -> Reaction -> Reaction@@ -789,6 +795,8 @@   if emoji == reaction ^. #emoji     then       reaction-        & #count %~ pred-        & #me %~ (&& not isMe)+        & #count+        %~ pred+        & #me+        %~ (&& not isMe)     else reaction

@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}+ -- | Contains stuff for managing shards module Calamity.Client.ShardManager (shardBot) where @@ -21,7 +23,7 @@ mapLeft _ (Right b) = Right b  -- | Connects the bot to the gateway over n shards-shardBot :: BotC r => Maybe StatusUpdateData -> Intents -> Sem r (Either StartupError ())+shardBot :: (BotC r) => Maybe StatusUpdateData -> Intents -> Sem r (Either StartupError ()) shardBot initialStatus intents = (mapLeft StartupError <$>) . P.runFail $ do   numShardsVar <- P.asks numShards   shardsVar <- P.asks shards

@@ -375,7 +375,7 @@         (\(EH ehs) -> EH $ filter ((/= id') . ehID) ehs)         handlers -getCustomEventHandlers :: forall a. Typeable a => EventHandlers -> [a -> IO ()]+getCustomEventHandlers :: forall a. (Typeable a) => EventHandlers -> [a -> IO ()] getCustomEventHandlers (EventHandlers handlers) =   let handlerMap =         unwrapEventHandler @('CustomEvt Void) $

@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}  -- | 'ParameterParser' instances for calamity models module Calamity.Commands.CalamityParsers () where@@ -24,12 +25,12 @@ import Text.Megaparsec.Char.Lexer (decimal) import Text.Megaparsec.Error.Builder (errFancy, fancy) -parserName :: forall a c r. ParameterParser a c r => T.Text+parserName :: forall a c r. (ParameterParser a c r) => T.Text parserName =   let ParameterInfo (fromMaybe "" -> name) type_ _ = parameterInfo @a @c @r    in name <> ":" <> T.pack (show type_) -instance Typeable (Snowflake a) => ParameterParser (Snowflake a) c r where+instance (Typeable (Snowflake a)) => ParameterParser (Snowflake a) c r where   parse = parseMP (parserName @(Snowflake a)) snowflake   parameterDescription = "discord id" @@ -88,7 +89,7 @@  'User'@ and use 'Calamity.Types.Upgradeable.upgrade' if you want to allow  fetching from http. -}-instance P.Member CacheEff r => ParameterParser User c r where+instance (P.Member CacheEff r) => ParameterParser User c r where   parse =     parseMP (parserName @User @c @r) $       mapParserMaybeM@@ -118,7 +119,7 @@  and use 'Calamity.Types.Upgradeable.upgrade' if you want to allow fetching  from http. -}-instance P.Member CacheEff r => ParameterParser Guild c r where+instance (P.Member CacheEff r) => ParameterParser Guild c r where   parse =     parseMP (parserName @Guild @c @r) $       mapParserMaybeM@@ -171,16 +172,16 @@ -- skipN :: (Stream s, Ord e) => Int -> ParsecT e s m () -- skipN n = void $ takeP Nothing n -ping :: MonadParsec e T.Text m => T.Text -> m (Snowflake a)+ping :: (MonadParsec e T.Text m) => T.Text -> m (Snowflake a) ping c = chunk ("<" <> c) *> optional (chunk "!") *> snowflake <* chunk ">" -ping' :: MonadParsec e T.Text m => m () -> m (Snowflake a)+ping' :: (MonadParsec e T.Text m) => m () -> m (Snowflake a) ping' m = chunk "<" *> m *> snowflake <* chunk ">" -snowflake :: MonadParsec e T.Text m => m (Snowflake a)+snowflake :: (MonadParsec e T.Text m) => m (Snowflake a) snowflake = Snowflake <$> decimal -partialEmoji :: MonadParsec e T.Text m => m (Partial Emoji)+partialEmoji :: (MonadParsec e T.Text m) => m (Partial Emoji) partialEmoji = do   animated <- isJust <$> (chunk "<" *> optional (chunk "a"))   name <- between (chunk ":") (chunk ":") (takeWhileP (Just "Emoji name") (/= ':'))@@ -188,7 +189,7 @@   void $ chunk ">"   pure (PartialEmoji id name animated) -emoji :: MonadParsec e T.Text m => m (Snowflake a)+emoji :: (MonadParsec e T.Text m) => m (Snowflake a) emoji = ping' (optional (chunk "a") *> between (chunk ":") (chunk ":") (void $ takeWhileP Nothing (/= ':')))  -- trackOffsets :: MonadParsec e s m => m a -> m (a, Int)

@@ -26,7 +26,7 @@ import Polysemy.Fail qualified as P import TextShow qualified -class CommandContext c => CalamityCommandContext c where+class (CommandContext c) => CalamityCommandContext c where   -- | The id of the channel that invoked this command   ctxChannelID :: c -> Snowflake Channel @@ -83,14 +83,14 @@ instance Tellable FullContext where   getChannel = pure . ctxChannelID -useFullContext :: P.Member CacheEff r => P.Sem (CC.ConstructContext (Message, User, Maybe Member) FullContext IO () ': r) a -> P.Sem r a+useFullContext :: (P.Member CacheEff r) => P.Sem (CC.ConstructContext (Message, User, Maybe Member) FullContext IO () ': r) a -> P.Sem r a useFullContext =   P.interpret     ( \case         CC.ConstructContext (pre, cmd, up) (msg, usr, mem) -> buildContext msg usr mem pre cmd up     ) -buildContext :: P.Member CacheEff r => Message -> User -> Maybe Member -> T.Text -> Command FullContext -> T.Text -> P.Sem r (Maybe FullContext)+buildContext :: (P.Member CacheEff r) => Message -> User -> Maybe Member -> T.Text -> Command FullContext -> T.Text -> P.Sem r (Maybe FullContext) buildContext msg usr mem prefix command unparsed = (rightToMaybe <$>) . P.runFail $ do   guild <- join <$> getGuild `traverse` (msg ^. #guildID)   let member = mem <|> guild ^? _Just % #members % ix (coerceSnowflake $ getID @User msg)

@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}+ {- | A DSL for generating commands and groups   This is effectively just a re-export of "CalamityCommands.Dsl" but with@@ -203,14 +205,14 @@  action to hidden. -} hide ::-  P.Member (P.Tagged "hidden" (P.Reader Bool)) r =>+  (P.Member (P.Tagged "hidden" (P.Reader Bool)) r) =>   P.Sem r a ->   P.Sem r a hide = CC.hide  -- | Set the help for any groups or commands registered inside the given action. help ::-  P.Member (P.Reader (c -> T.Text)) r =>+  (P.Member (P.Reader (c -> T.Text)) r) =>   (c -> T.Text) ->   P.Sem r a ->   P.Sem r a@@ -220,7 +222,7 @@  action. -} requires ::-  DSLC c r =>+  (DSLC c r) =>   [Check c] ->   P.Sem r a ->   P.Sem r a@@ -247,7 +249,7 @@  Refer to 'CalamityCommands.Check.Check' for more info on checks. -} requiresPure ::-  DSLC c r =>+  (DSLC c r) =>   [(T.Text, c -> Maybe T.Text)] ->   -- A list of check names and check callbacks   P.Sem r a ->@@ -324,5 +326,5 @@ groupA' = CC.groupA'  -- | Retrieve the final command handler for this block-fetchHandler :: DSLC c r => P.Sem r (CommandHandler c)+fetchHandler :: (DSLC c r) => P.Sem r (CommandHandler c) fetchHandler = P.ask

@@ -30,12 +30,12 @@  data CalamityEvent   = Dispatch+      -- | The shard that pushed this event       Int-      -- ^ The shard that pushed this event+      -- | The attached data       DispatchData-      -- ^ The attached data   | -- | The data sent to the custom event-    forall (a :: Type). Typeable a => Custom a+    forall (a :: Type). (Typeable a) => Custom a   | ShutDown  data DispatchData

@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}+ -- | The shard logic module Calamity.Gateway.Shard (   Shard (..),@@ -109,7 +111,7 @@ import Prelude hiding (error)  runWebsocket ::-  P.Members '[LogEff, P.Final IO, P.Embed IO] r =>+  (P.Members '[LogEff, P.Final IO, P.Embed IO] r) =>   T.Text ->   T.Text ->   (Connection -> P.Sem r a) ->@@ -155,7 +157,7 @@  -- | Creates and launches a shard newShard ::-  P.Members '[LogEff, MetricEff, P.Embed IO, P.Final IO, P.Async] r =>+  (P.Members '[LogEff, MetricEff, P.Embed IO, P.Final IO, P.Async] r) =>   T.Text ->   Int ->   Int ->@@ -176,7 +178,7 @@    pure (cmdIn, thread') -sendToWs :: ShardC r => SentDiscordMessage -> Sem r ()+sendToWs :: (ShardC r) => SentDiscordMessage -> Sem r () sendToWs data' = do   wsConn' <- P.atomicGets wsConn   case wsConn' of@@ -194,14 +196,14 @@     Just True -> pure True     Nothing -> pure False -restartUnless :: P.Members '[LogEff, P.Error ShardFlowControl] r => T.Text -> Maybe a -> P.Sem r a+restartUnless :: (P.Members '[LogEff, P.Error ShardFlowControl] r) => T.Text -> Maybe a -> P.Sem r a restartUnless _ (Just a) = pure a restartUnless msg Nothing = do   error msg   P.throw ShardFlowRestart  -- | The loop a shard will run on-shardLoop :: ShardC r => Sem r ()+shardLoop :: (ShardC r) => Sem r () shardLoop = do   activeShards <- registerGauge "active_shards" mempty   void $ modifyGauge (+ 1) activeShards@@ -225,7 +227,7 @@             Left (ShutDownShard, Just . showt $ code)       e -> Left (RestartShard, Just . T.pack . show $ e) -    discordStream :: P.Members '[LogEff, MetricEff, P.Embed IO, P.Final IO] r => Connection -> TBMQueue ShardMsg -> Sem r ()+    discordStream :: (P.Members '[LogEff, MetricEff, P.Embed IO, P.Final IO] r) => Connection -> TBMQueue ShardMsg -> Sem r ()     discordStream ws outqueue = inner       where         inner = do@@ -245,7 +247,7 @@                   error . T.pack $ "Failed to decode " <> e <> ": " <> show msg'                   pure True               when r inner-    outerloop :: ShardC r => Sem r ()+    outerloop :: (ShardC r) => Sem r ()     outerloop = whileMFinalIO $ do       shard :: Shard <- P.atomicGets (^. #shardS)       let host = shard ^. #gateway@@ -268,7 +270,7 @@           info "Restarting shard (abnormal reasons?)"           pure True -    innerloop :: ShardC r => Connection -> Sem r ShardFlowControl+    innerloop :: (ShardC r) => Connection -> Sem r ShardFlowControl     innerloop ws = do       debug "Entering inner loop of shard" @@ -370,13 +372,13 @@       RestartShard -> P.throw ShardFlowRestart       ShutDownShard -> P.throw ShardFlowShutDown -startHeartBeatLoop :: ShardC r => Int -> Sem r ()+startHeartBeatLoop :: (ShardC r) => Int -> Sem r () startHeartBeatLoop interval = do   haltHeartBeat -- cancel any currently running hb thread   thread <- P.async $ heartBeatLoop interval   P.atomicModify' (#hbThread ?~ thread) -haltHeartBeat :: ShardC r => Sem r ()+haltHeartBeat :: (ShardC r) => Sem r () haltHeartBeat = do   thread <- P.atomicState @ShardState . (swap .) . runState $ do     thread <- use #hbThread@@ -388,14 +390,14 @@       P.embed (void $ cancel t)     Nothing -> pure () -sendHeartBeat :: ShardC r => Sem r ()+sendHeartBeat :: (ShardC r) => Sem r () sendHeartBeat = do   sn <- P.atomicGets (^. #seqNum)   debug . T.pack $ "Sending heartbeat (seq: " <> show sn <> ")"   sendToWs $ HeartBeat sn   P.atomicModify' (#hbResponse .~ False) -heartBeatLoop :: ShardC r => Int -> Sem r ()+heartBeatLoop :: (ShardC r) => Int -> Sem r () heartBeatLoop interval = untilJustFinalIO . (leftToMaybe <$>) . P.runError $ do   sendHeartBeat   P.embed . threadDelay $ interval * 1000

@@ -24,7 +24,7 @@   def = GetAuditLogOptions Nothing Nothing Nothing Nothing  data AuditLogRequest a where-  GetAuditLog :: HasID Guild g => g -> GetAuditLogOptions -> AuditLogRequest AuditLog+  GetAuditLog :: (HasID Guild g) => g -> GetAuditLogOptions -> AuditLogRequest AuditLog  instance Request (AuditLogRequest a) where   type Result (AuditLogRequest a) = a

@@ -320,8 +320,10 @@  baseRoute :: Snowflake Channel -> RouteBuilder _ baseRoute id =-  mkRouteBuilder // S "channels" // ID @Channel-    & giveID id+  mkRouteBuilder+    // S "channels"+    // ID @Channel+      & giveID id  renderEmoji :: RawEmoji -> Text renderEmoji (UnicodeEmoji e) = e@@ -331,12 +333,15 @@   type Result (ChannelRequest a) = a    route (CreateMessage (getID -> id) _) =-    baseRoute id // S "messages"-      & buildRoute+    baseRoute id+      // S "messages"+        & buildRoute   route (CrosspostMessage (getID -> id) (getID @Message -> mid)) =-    baseRoute id // S "messages" // ID @Message-      & giveID mid-      & buildRoute+    baseRoute id+      // S "messages"+      // ID @Message+        & giveID mid+        & buildRoute   route (GetChannel (getID -> id)) =     baseRoute id       & buildRoute@@ -347,84 +352,131 @@     baseRoute id       & buildRoute   route (GetChannelMessages (getID -> id) _ _) =-    baseRoute id // S "messages"-      & buildRoute+    baseRoute id+      // S "messages"+        & buildRoute   route (GetMessage (getID -> cid) (getID @Message -> mid)) =-    baseRoute cid // S "messages" // ID @Message-      & giveID mid-      & buildRoute+    baseRoute cid+      // S "messages"+      // ID @Message+        & giveID mid+        & buildRoute   route (CreateReaction (getID -> cid) (getID @Message -> mid) emoji) =-    baseRoute cid // S "messages" // ID @Message // S "reactions" // PS @"emoji" // S "@me"-      & giveID mid-      & giveParam @"emoji" (renderEmoji emoji)-      & buildRoute+    baseRoute cid+      // S "messages"+      // ID @Message+      // S "reactions"+      // PS @"emoji"+      // S "@me"+        & giveID mid+        & giveParam @"emoji" (renderEmoji emoji)+        & buildRoute   route (DeleteOwnReaction (getID -> cid) (getID @Message -> mid) emoji) =-    baseRoute cid // S "messages" // ID @Message // S "reactions" // PS @"emoji" // S "@me"-      & giveID mid-      & giveParam @"emoji" (renderEmoji emoji)-      & buildRoute+    baseRoute cid+      // S "messages"+      // ID @Message+      // S "reactions"+      // PS @"emoji"+      // S "@me"+        & giveID mid+        & giveParam @"emoji" (renderEmoji emoji)+        & buildRoute   route (DeleteUserReaction (getID -> cid) (getID @Message -> mid) emoji (getID @User -> uid)) =-    baseRoute cid // S "messages" // ID @Message // S "reactions" // PS @"emoji" // ID @User-      & giveID mid-      & giveID uid-      & giveParam @"emoji" (renderEmoji emoji)-      & buildRoute+    baseRoute cid+      // S "messages"+      // ID @Message+      // S "reactions"+      // PS @"emoji"+      // ID @User+        & giveID mid+        & giveID uid+        & giveParam @"emoji" (renderEmoji emoji)+        & buildRoute   route (GetReactions (getID -> cid) (getID @Message -> mid) emoji _) =-    baseRoute cid // S "messages" // ID @Message // S "reactions" // PS @"emoji"-      & giveID mid-      & giveParam @"emoji" (renderEmoji emoji)-      & buildRoute+    baseRoute cid+      // S "messages"+      // ID @Message+      // S "reactions"+      // PS @"emoji"+        & giveID mid+        & giveParam @"emoji" (renderEmoji emoji)+        & buildRoute   route (DeleteAllReactions (getID -> cid) (getID @Message -> mid)) =-    baseRoute cid // S "messages" // ID @Message // S "reactions"-      & giveID mid-      & buildRoute+    baseRoute cid+      // S "messages"+      // ID @Message+      // S "reactions"+        & giveID mid+        & buildRoute   route (EditMessage (getID -> cid) (getID @Message -> mid) _) =-    baseRoute cid // S "messages" // ID @Message-      & giveID mid-      & buildRoute+    baseRoute cid+      // S "messages"+      // ID @Message+        & giveID mid+        & buildRoute   route (DeleteMessage (getID -> cid) (getID @Message -> mid)) =-    baseRoute cid // S "messages" // ID @Message-      & giveID mid-      & buildRoute+    baseRoute cid+      // S "messages"+      // ID @Message+        & giveID mid+        & buildRoute   route (BulkDeleteMessages (getID -> cid) _) =-    baseRoute cid // S "messages" // S "bulk-delete"-      & buildRoute+    baseRoute cid+      // S "messages"+      // S "bulk-delete"+        & buildRoute   route (GetChannelInvites (getID -> cid)) =-    baseRoute cid // S "invites"-      & buildRoute+    baseRoute cid+      // S "invites"+        & buildRoute   route (CreateChannelInvite (getID -> cid) _) =-    baseRoute cid // S "invites"-      & buildRoute+    baseRoute cid+      // S "invites"+        & buildRoute   route (EditChannelPermissions (getID -> cid) (getID @Overwrite -> oid)) =-    baseRoute cid // S "permissions" // ID @Overwrite-      & giveID oid-      & buildRoute+    baseRoute cid+      // S "permissions"+      // ID @Overwrite+        & giveID oid+        & buildRoute   route (DeleteChannelPermission (getID -> cid) (getID @Overwrite -> oid)) =-    baseRoute cid // S "permissions" // ID @Overwrite-      & giveID oid-      & buildRoute+    baseRoute cid+      // S "permissions"+      // ID @Overwrite+        & giveID oid+        & buildRoute   route (TriggerTyping (getID -> cid)) =-    baseRoute cid // S "typing"-      & buildRoute+    baseRoute cid+      // S "typing"+        & buildRoute   route (GetPinnedMessages (getID -> cid)) =-    baseRoute cid // S "pins"-      & buildRoute+    baseRoute cid+      // S "pins"+        & buildRoute   route (AddPinnedMessage (getID -> cid) (getID @Message -> mid)) =-    baseRoute cid // S "pins" // ID @Message-      & giveID mid-      & buildRoute+    baseRoute cid+      // S "pins"+      // ID @Message+        & giveID mid+        & buildRoute   route (DeletePinnedMessage (getID -> cid) (getID @Message -> mid)) =-    baseRoute cid // S "pins" // ID @Message-      & giveID mid-      & buildRoute+    baseRoute cid+      // S "pins"+      // ID @Message+        & giveID mid+        & buildRoute   route (GroupDMAddRecipient (getID -> cid) (getID @User -> uid) _) =-    baseRoute cid // S "recipients" // ID @User-      & giveID uid-      & buildRoute+    baseRoute cid+      // S "recipients"+      // ID @User+        & giveID uid+        & buildRoute   route (GroupDMRemoveRecipient (getID -> cid) (getID @User -> uid)) =-    baseRoute cid // S "recipients" // ID @User-      & giveID uid-      & buildRoute+    baseRoute cid+      // S "recipients"+      // ID @User+        & giveID uid+        & buildRoute   action (CreateMessage _ cm) = \u o -> do     let filePart CreateMessageAttachment {filename, content} n =           (partFileRequestBody @IO (T.pack $ "files[" <> show n <> "]") "" content)

@@ -303,46 +303,49 @@  data GuildRequest a where   CreateGuild :: CreateGuildData -> GuildRequest Guild-  GetGuild :: HasID Guild g => g -> GuildRequest Guild-  ModifyGuild :: HasID Guild g => g -> ModifyGuildData -> GuildRequest Guild-  DeleteGuild :: HasID Guild g => g -> GuildRequest ()-  GetGuildChannels :: HasID Guild g => g -> GuildRequest [Channel]-  CreateGuildChannel :: HasID Guild g => g -> ChannelCreateData -> GuildRequest Channel-  ModifyGuildChannelPositions :: HasID Guild g => g -> [ChannelPosition] -> GuildRequest ()+  GetGuild :: (HasID Guild g) => g -> GuildRequest Guild+  ModifyGuild :: (HasID Guild g) => g -> ModifyGuildData -> GuildRequest Guild+  DeleteGuild :: (HasID Guild g) => g -> GuildRequest ()+  GetGuildChannels :: (HasID Guild g) => g -> GuildRequest [Channel]+  CreateGuildChannel :: (HasID Guild g) => g -> ChannelCreateData -> GuildRequest Channel+  ModifyGuildChannelPositions :: (HasID Guild g) => g -> [ChannelPosition] -> GuildRequest ()   GetGuildMember :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest Member-  ListGuildMembers :: HasID Guild g => g -> ListMembersOptions -> GuildRequest [Member]-  SearchGuildMembers :: HasID Guild g => g -> SearchMembersOptions -> GuildRequest [Member]+  ListGuildMembers :: (HasID Guild g) => g -> ListMembersOptions -> GuildRequest [Member]+  SearchGuildMembers :: (HasID Guild g) => g -> SearchMembersOptions -> GuildRequest [Member]   AddGuildMember :: (HasID Guild g, HasID User u) => g -> u -> AddGuildMemberData -> GuildRequest (Maybe Member)   ModifyGuildMember :: (HasID Guild g, HasID User u) => g -> u -> ModifyGuildMemberData -> GuildRequest ()-  ModifyCurrentUserNick :: HasID Guild g => g -> Maybe Text -> GuildRequest ()+  ModifyCurrentUserNick :: (HasID Guild g) => g -> Maybe Text -> GuildRequest ()   AddGuildMemberRole :: (HasID Guild g, HasID User u, HasID Role r) => g -> u -> r -> GuildRequest ()   RemoveGuildMemberRole :: (HasID Guild g, HasID User u, HasID Role r) => g -> u -> r -> GuildRequest ()   RemoveGuildMember :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest ()-  GetGuildBans :: HasID Guild g => g -> GetGuildBansOptions -> GuildRequest [BanData]+  GetGuildBans :: (HasID Guild g) => g -> GetGuildBansOptions -> GuildRequest [BanData]   GetGuildBan :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest BanData   CreateGuildBan :: (HasID Guild g, HasID User u) => g -> u -> CreateGuildBanData -> GuildRequest ()   RemoveGuildBan :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest ()-  GetGuildRoles :: HasID Guild g => g -> GuildRequest [Role]-  CreateGuildRole :: HasID Guild g => g -> ModifyGuildRoleData -> GuildRequest Role-  ModifyGuildRolePositions :: HasID Guild g => g -> ModifyGuildRolePositionsData -> GuildRequest [Role]+  GetGuildRoles :: (HasID Guild g) => g -> GuildRequest [Role]+  CreateGuildRole :: (HasID Guild g) => g -> ModifyGuildRoleData -> GuildRequest Role+  ModifyGuildRolePositions :: (HasID Guild g) => g -> ModifyGuildRolePositionsData -> GuildRequest [Role]   ModifyGuildRole :: (HasID Guild g, HasID Role r) => g -> r -> ModifyGuildRoleData -> GuildRequest Role   DeleteGuildRole :: (HasID Guild g, HasID Role r) => g -> r -> GuildRequest ()-  GetGuildPruneCount :: HasID Guild g => g -> Integer -> GuildRequest Integer-  BeginGuildPrune :: HasID Guild g => g -> Integer -> Bool -> GuildRequest (Maybe Integer)-  GetGuildVoiceRegions :: HasID Guild g => g -> GuildRequest [VoiceRegion]-  GetGuildInvites :: HasID Guild g => g -> GuildRequest [Invite]+  GetGuildPruneCount :: (HasID Guild g) => g -> Integer -> GuildRequest Integer+  BeginGuildPrune :: (HasID Guild g) => g -> Integer -> Bool -> GuildRequest (Maybe Integer)+  GetGuildVoiceRegions :: (HasID Guild g) => g -> GuildRequest [VoiceRegion]+  GetGuildInvites :: (HasID Guild g) => g -> GuildRequest [Invite]  baseRoute :: Snowflake Guild -> RouteBuilder _ baseRoute id =-  mkRouteBuilder // S "guilds" // ID @Guild-    & giveID id+  mkRouteBuilder+    // S "guilds"+    // ID @Guild+      & giveID id  instance Request (GuildRequest a) where   type Result (GuildRequest a) = a    route (CreateGuild _) =-    mkRouteBuilder // S "guilds"-      & buildRoute+    mkRouteBuilder+      // S "guilds"+        & buildRoute   route (GetGuild (getID -> gid)) =     baseRoute gid       & buildRoute@@ -353,93 +356,136 @@     baseRoute gid       & buildRoute   route (GetGuildChannels (getID -> gid)) =-    baseRoute gid // S "channels"-      & buildRoute+    baseRoute gid+      // S "channels"+        & buildRoute   route (CreateGuildChannel (getID -> gid) _) =-    baseRoute gid // S "channels"-      & buildRoute+    baseRoute gid+      // S "channels"+        & buildRoute   route (ModifyGuildChannelPositions (getID -> gid) _) =-    baseRoute gid // S "channels"-      & buildRoute+    baseRoute gid+      // S "channels"+        & buildRoute   route (GetGuildMember (getID -> gid) (getID @User -> uid)) =-    baseRoute gid // S "members" // ID @User-      & giveID uid-      & buildRoute+    baseRoute gid+      // S "members"+      // ID @User+        & giveID uid+        & buildRoute   route (ListGuildMembers (getID -> gid) _) =-    baseRoute gid // S "members"-      & buildRoute+    baseRoute gid+      // S "members"+        & buildRoute   route (SearchGuildMembers (getID -> gid) _) =-    baseRoute gid // S "members" // S "search"-      & buildRoute+    baseRoute gid+      // S "members"+      // S "search"+        & buildRoute   route (AddGuildMember (getID -> gid) (getID @User -> uid) _) =-    baseRoute gid // S "members" // ID @User-      & giveID uid-      & buildRoute+    baseRoute gid+      // S "members"+      // ID @User+        & giveID uid+        & buildRoute   route (ModifyGuildMember (getID -> gid) (getID @User -> uid) _) =-    baseRoute gid // S "members" // ID @User-      & giveID uid-      & buildRoute+    baseRoute gid+      // S "members"+      // ID @User+        & giveID uid+        & buildRoute   route (ModifyCurrentUserNick (getID -> gid) _) =-    baseRoute gid // S "members" // S "@me" // S "nick"-      & buildRoute+    baseRoute gid+      // S "members"+      // S "@me"+      // S "nick"+        & buildRoute   route (AddGuildMemberRole (getID -> gid) (getID @User -> uid) (getID @Role -> rid)) =-    baseRoute gid // S "members" // ID @User // S "roles" // ID @Role-      & giveID uid-      & giveID rid-      & buildRoute+    baseRoute gid+      // S "members"+      // ID @User+      // S "roles"+      // ID @Role+        & giveID uid+        & giveID rid+        & buildRoute   route (RemoveGuildMemberRole (getID -> gid) (getID @User -> uid) (getID @Role -> rid)) =-    baseRoute gid // S "members" // ID @User // S "roles" // ID @Role-      & giveID uid-      & giveID rid-      & buildRoute+    baseRoute gid+      // S "members"+      // ID @User+      // S "roles"+      // ID @Role+        & giveID uid+        & giveID rid+        & buildRoute   route (RemoveGuildMember (getID -> gid) (getID @User -> uid)) =-    baseRoute gid // S "members" // ID @User-      & giveID uid-      & buildRoute+    baseRoute gid+      // S "members"+      // ID @User+        & giveID uid+        & buildRoute   route (GetGuildBans (getID -> gid) _) =-    baseRoute gid // S "bans"-      & buildRoute+    baseRoute gid+      // S "bans"+        & buildRoute   route (GetGuildBan (getID -> gid) (getID @User -> uid)) =-    baseRoute gid // S "bans" // ID @User-      & giveID uid-      & buildRoute+    baseRoute gid+      // S "bans"+      // ID @User+        & giveID uid+        & buildRoute   route (CreateGuildBan (getID -> gid) (getID @User -> uid) _) =-    baseRoute gid // S "bans" // ID @User-      & giveID uid-      & buildRoute+    baseRoute gid+      // S "bans"+      // ID @User+        & giveID uid+        & buildRoute   route (RemoveGuildBan (getID -> gid) (getID @User -> uid)) =-    baseRoute gid // S "bans" // ID @User-      & giveID uid-      & buildRoute+    baseRoute gid+      // S "bans"+      // ID @User+        & giveID uid+        & buildRoute   route (GetGuildRoles (getID -> gid)) =-    baseRoute gid // S "roles"-      & buildRoute+    baseRoute gid+      // S "roles"+        & buildRoute   route (CreateGuildRole (getID -> gid) _) =-    baseRoute gid // S "roles"-      & buildRoute+    baseRoute gid+      // S "roles"+        & buildRoute   route (ModifyGuildRolePositions (getID -> gid) _) =-    baseRoute gid // S "roles"-      & buildRoute+    baseRoute gid+      // S "roles"+        & buildRoute   route (ModifyGuildRole (getID -> gid) (getID @Role -> rid) _) =-    baseRoute gid // S "roles" // ID @Role-      & giveID rid-      & buildRoute+    baseRoute gid+      // S "roles"+      // ID @Role+        & giveID rid+        & buildRoute   route (DeleteGuildRole (getID -> gid) (getID @Role -> rid)) =-    baseRoute gid // S "roles" // ID @Role-      & giveID rid-      & buildRoute+    baseRoute gid+      // S "roles"+      // ID @Role+        & giveID rid+        & buildRoute   route (GetGuildPruneCount (getID -> gid) _) =-    baseRoute gid // S "prune"-      & buildRoute+    baseRoute gid+      // S "prune"+        & buildRoute   route (BeginGuildPrune (getID -> gid) _ _) =-    baseRoute gid // S "prune"-      & buildRoute+    baseRoute gid+      // S "prune"+        & buildRoute   route (GetGuildVoiceRegions (getID -> gid)) =-    baseRoute gid // S "regions"-      & buildRoute+    baseRoute gid+      // S "regions"+        & buildRoute   route (GetGuildInvites (getID -> gid)) =-    baseRoute gid // S "invites"-      & buildRoute+    baseRoute gid+      // S "invites"+        & buildRoute    action (CreateGuild o) = postWith' (ReqBodyJson o)   action (GetGuild _) = getWith

@@ -259,8 +259,11 @@  baseRoute :: Snowflake Application -> InteractionToken -> RouteBuilder _ baseRoute id (InteractionToken token) =-  mkRouteBuilder // S "webhooks" // ID @Application // S token-    & giveID id+  mkRouteBuilder+    // S "webhooks"+    // ID @Application+    // S token+      & giveID id  foo :: Maybe a -> Maybe a -> (a -> a -> a) -> Maybe a foo (Just x) (Just y) f = Just (f x y)@@ -270,29 +273,53 @@   type Result (InteractionRequest a) = a    route (CreateResponseDefer (getID @Interaction -> iid) (InteractionToken token) _) =-    mkRouteBuilder // S "interactions" // ID @Interaction // S token // S "callback"-      & giveID iid-      & buildRoute+    mkRouteBuilder+      // S "interactions"+      // ID @Interaction+      // S token+      // S "callback"+        & giveID iid+        & buildRoute   route (CreateResponseDeferComponent (getID @Interaction -> iid) (InteractionToken token)) =-    mkRouteBuilder // S "interactions" // ID @Interaction // S token // S "callback"-      & giveID iid-      & buildRoute+    mkRouteBuilder+      // S "interactions"+      // ID @Interaction+      // S token+      // S "callback"+        & giveID iid+        & buildRoute   route (CreateResponseMessage (getID @Interaction -> iid) (InteractionToken token) _) =-    mkRouteBuilder // S "interactions" // ID @Interaction // S token // S "callback"-      & giveID iid-      & buildRoute+    mkRouteBuilder+      // S "interactions"+      // ID @Interaction+      // S token+      // S "callback"+        & giveID iid+        & buildRoute   route (CreateResponseUpdate (getID @Interaction -> iid) (InteractionToken token) _) =-    mkRouteBuilder // S "interactions" // ID @Interaction // S token // S "callback"-      & giveID iid-      & buildRoute+    mkRouteBuilder+      // S "interactions"+      // ID @Interaction+      // S token+      // S "callback"+        & giveID iid+        & buildRoute   route (CreateResponseAutocomplete (getID @Interaction -> iid) (InteractionToken token) _) =-    mkRouteBuilder // S "interactions" // ID @Interaction // S token // S "callback"-      & giveID iid-      & buildRoute+    mkRouteBuilder+      // S "interactions"+      // ID @Interaction+      // S token+      // S "callback"+        & giveID iid+        & buildRoute   route (CreateResponseModal (getID @Interaction -> iid) (InteractionToken token) _) =-    mkRouteBuilder // S "interactions" // ID @Interaction // S token // S "callback"-      & giveID iid-      & buildRoute+    mkRouteBuilder+      // S "interactions"+      // ID @Interaction+      // S token+      // S "callback"+        & giveID iid+        & buildRoute   route (GetOriginalInteractionResponse (getID @Application -> aid) token) =     baseRoute aid token // S "messages" // S "@original" & buildRoute   route (EditOriginalInteractionResponse (getID @Application -> aid) token _) =

@@ -118,8 +118,11 @@     (bucket ^. #state)     ( \bs ->         bs-          & #remaining .~ bs ^. #limit-          & #resetTime .~ Nothing+          & #remaining+          .~ bs+          ^. #limit+          & #resetTime+          .~ Nothing     )  canResetBucketNow :: UTCTime -> BucketState -> Bool@@ -206,40 +209,40 @@           -- print "ok going forward with request"           pure () -doDiscordRequest :: P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r => IO LbsResponse -> Sem r DiscordResponseType+doDiscordRequest :: (P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r) => IO LbsResponse -> Sem r DiscordResponseType doDiscordRequest r = do   r'' <- P.embed $ Ex.catchAny (Right <$> r) (pure . Left . Ex.displayException)   case r'' of     Right r' -> do       let status = responseStatus . toVanillaResponse $ r'       if-          | statusIsSuccessful status -> do-              let resp = responseBody r'-              debug $ "Got good response from discord: " <> (T.pack . show $ status)-              now <- P.embed getCurrentTime-              let rlHeaders = buildBucketState now r'-              pure $ Good resp rlHeaders-          | status == status429 -> do-              now <- P.embed getCurrentTime-              let resp = responseBody r'-              case (resp ^? _Value, buildBucketState now r') of-                (Just !rv, bs) ->-                  pure $ Ratelimited (parseRetryAfter now rv) (isGlobal rv) bs-                _ ->-                  pure $ ServerError (statusCode status)-          | statusIsClientError status -> do-              let err = responseBody r'-              error . T.pack $ "Something went wrong: " <> show err <> ", response: " <> show r'-              pure $ ClientError (statusCode status) err-          | otherwise -> do-              debug . T.pack $ "Got server error from discord: " <> (show . statusCode $ status)-              pure $ ServerError (statusCode status)+        | statusIsSuccessful status -> do+            let resp = responseBody r'+            debug $ "Got good response from discord: " <> (T.pack . show $ status)+            now <- P.embed getCurrentTime+            let rlHeaders = buildBucketState now r'+            pure $ Good resp rlHeaders+        | status == status429 -> do+            now <- P.embed getCurrentTime+            let resp = responseBody r'+            case (resp ^? _Value, buildBucketState now r') of+              (Just !rv, bs) ->+                pure $ Ratelimited (parseRetryAfter now rv) (isGlobal rv) bs+              _ ->+                pure $ ServerError (statusCode status)+        | statusIsClientError status -> do+            let err = responseBody r'+            error . T.pack $ "Something went wrong: " <> show err <> ", response: " <> show r'+            pure $ ClientError (statusCode status) err+        | otherwise -> do+            debug . T.pack $ "Got server error from discord: " <> (show . statusCode $ status)+            pure $ ServerError (statusCode status)     Left e -> do       error . T.pack $ "Something went wrong with the http client: " <> e       pure . InternalResponseError $ T.pack e  -- | Parse a ratelimit header returning when it unlocks-parseRateLimitHeader :: HttpResponse r => UTCTime -> r -> Maybe UTCTime+parseRateLimitHeader :: (HttpResponse r) => UTCTime -> r -> Maybe UTCTime parseRateLimitHeader now r = computedEnd <|> end   where     computedEnd :: Maybe UTCTime@@ -253,10 +256,10 @@       posixSecondsToUTCTime         . realToFrac         <$> responseHeader r "X-Ratelimit-Reset"-        ^? _Just-        % _Double+          ^? _Just+          % _Double -buildBucketState :: HttpResponse r => UTCTime -> r -> Maybe (BucketState, B.ByteString)+buildBucketState :: (HttpResponse r) => UTCTime -> r -> Maybe (BucketState, B.ByteString) buildBucketState now r = (,) <$> bs <*> bucketKey   where     remaining = responseHeader r "X-RateLimit-Remaining" ^? _Just % _Integral@@ -282,7 +285,7 @@   | RGood b  retryRequest ::-  P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r =>+  (P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r) =>   -- | number of retries   Int ->   -- | action to perform@@ -319,7 +322,7 @@  -- Run a single request doSingleRequest ::-  P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r =>+  (P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r) =>   RateLimitState ->   Route ->   -- | Global lock@@ -416,7 +419,7 @@         _ -> debug "unknown ratelimit"       pure $ RFail (HTTPError c $ Aeson.decode v) -doRequest :: P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r => RateLimitState -> Route -> IO LbsResponse -> Sem r (Either RestError LB.ByteString)+doRequest :: (P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r) => RateLimitState -> Route -> IO LbsResponse -> Sem r (Either RestError LB.ByteString) doRequest rlstate route action =   retryRequest     5

@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}+ -- | Generic Request type module Calamity.HTTP.Internal.Request (   Request (..),@@ -36,18 +38,18 @@ import Polysemy.Error qualified as P import Web.HttpApiData -throwIfLeft :: P.Member (P.Error RestError) r => Either String a -> P.Sem r a+throwIfLeft :: (P.Member (P.Error RestError) r) => Either String a -> P.Sem r a throwIfLeft (Right a) = pure a throwIfLeft (Left e) = P.throw (InternalClientError . T.pack $ e) -extractRight :: P.Member (P.Error e) r => Either e a -> P.Sem r a+extractRight :: (P.Member (P.Error e) r) => Either e a -> P.Sem r a extractRight (Left e) = P.throw e extractRight (Right a) = pure a  class ReadResponse a where   processResp :: LB.ByteString -> (Value -> Value) -> Either String a -instance {-# OVERLAPPABLE #-} FromJSON a => ReadResponse a where+instance {-# OVERLAPPABLE #-} (FromJSON a) => ReadResponse a where   processResp s f = eitherDecode s >>= parseEither parseJSON . f  instance ReadResponse () where@@ -109,19 +111,19 @@ getWith :: Url 'Https -> Option 'Https -> Req LbsResponse getWith u = req GET u NoReqBody lbsResponse -postWith' :: HttpBody a => a -> Url 'Https -> Option 'Https -> Req LbsResponse+postWith' :: (HttpBody a) => a -> Url 'Https -> Option 'Https -> Req LbsResponse postWith' a u = req POST u a lbsResponse -postWithP' :: HttpBody a => a -> Option 'Https -> Url 'Https -> Option 'Https -> Req LbsResponse+postWithP' :: (HttpBody a) => a -> Option 'Https -> Url 'Https -> Option 'Https -> Req LbsResponse postWithP' a o u o' = req POST u a lbsResponse (o <> o')  postEmpty :: Url 'Https -> Option 'Https -> Req LbsResponse postEmpty u = req POST u NoReqBody lbsResponse -putWith' :: HttpBody a => a -> Url 'Https -> Option 'Https -> Req LbsResponse+putWith' :: (HttpBody a) => a -> Url 'Https -> Option 'Https -> Req LbsResponse putWith' a u = req PUT u a lbsResponse -patchWith' :: HttpBody a => a -> Url 'Https -> Option 'Https -> Req LbsResponse+patchWith' :: (HttpBody a) => a -> Url 'Https -> Option 'Https -> Req LbsResponse patchWith' a u = req PATCH u a lbsResponse  putEmpty :: Url 'Https -> Option 'Https -> Req LbsResponse@@ -139,6 +141,6 @@ deleteWith :: Url 'Https -> Option 'Https -> Req LbsResponse deleteWith u = req DELETE u NoReqBody lbsResponse -(=:?) :: ToHttpApiData a => T.Text -> Maybe a -> Option 'Https+(=:?) :: (ToHttpApiData a) => T.Text -> Maybe a -> Option 'Https n =:? (Just x) = n =: x _ =:? Nothing = mempty

@@ -78,7 +78,7 @@  giveID ::   forall t reqs.-  Typeable t =>+  (Typeable t) =>   Snowflake t ->   RouteBuilder reqs ->   RouteBuilder ('( 'IDRequirement t, 'Satisfied) ': reqs)@@ -87,7 +87,7 @@  giveParam ::   forall (s :: Symbol) reqs.-  KnownSymbol s =>+  (KnownSymbol s) =>   Text ->   RouteBuilder reqs ->   RouteBuilder ('( 'PSRequirement s, 'Satisfied) ': reqs)@@ -126,7 +126,7 @@   AddRequiredInner ('Just 'NotNeeded) = 'Required   AddRequiredInner 'Nothing = 'Required -class Typeable a => RouteFragmentable a reqs where+class (Typeable a) => RouteFragmentable a reqs where   type ConsRes a reqs    (//) :: RouteBuilder reqs -> a -> ConsRes a reqs@@ -137,13 +137,13 @@   (UnsafeMkRouteBuilder r ids params) // (S t) =     UnsafeMkRouteBuilder (r <> [S' t]) ids params -instance Typeable a => RouteFragmentable (ID (a :: Type)) (reqs :: [(RequirementType, RouteRequirement)]) where+instance (Typeable a) => RouteFragmentable (ID (a :: Type)) (reqs :: [(RequirementType, RouteRequirement)]) where   type ConsRes (ID a) reqs = RouteBuilder (AddRequired ('IDRequirement a) reqs)    (UnsafeMkRouteBuilder r ids params) // ID =     UnsafeMkRouteBuilder (r <> [ID' $ typeRep $ Proxy @a]) ids params -instance KnownSymbol s => RouteFragmentable (PS s) (reqs :: [(RequirementType, RouteRequirement)]) where+instance (KnownSymbol s) => RouteFragmentable (PS s) (reqs :: [(RequirementType, RouteRequirement)]) where   type ConsRes (PS s) reqs = RouteBuilder (AddRequired ('PSRequirement s) reqs)    (UnsafeMkRouteBuilder r ids params) // PS =@@ -169,7 +169,7 @@  buildRoute ::   forall (reqs :: [(RequirementType, RouteRequirement)]).-  EnsureFulfilled reqs =>+  (EnsureFulfilled reqs) =>   RouteBuilder reqs ->   Route buildRoute (UnsafeMkRouteBuilder route ids params) =

@@ -61,14 +61,14 @@   = -- | A good response     Good       LB.ByteString+      -- | The ratelimit headers if we got them       (Maybe (BucketState, B.ByteString))-      -- ^ The ratelimit headers if we got them   | -- | We hit a 429, no response and ratelimited     Ratelimited+      -- | Retry after       UTCTime-      -- ^ Retry after+      -- | Global ratelimit       Bool-      -- ^ Global ratelimit       (Maybe (BucketState, B.ByteString))   | -- | Discord's error, we should retry (HTTP 5XX)     ServerError Int

@@ -13,10 +13,10 @@   deriving (Show, Eq)  -- | Attach a reason to a request-reason :: Request a => Text -> a -> Reason a+reason :: (Request a) => Text -> a -> Reason a reason = flip Reason -instance Request a => Request (Reason a) where+instance (Request a) => Request (Reason a) where   type Result (Reason a) = Result a    route (Reason a _) = route a

@@ -51,11 +51,11 @@  data UserRequest a where   GetCurrentUser :: UserRequest User-  GetUser :: HasID User u => u -> UserRequest User+  GetUser :: (HasID User u) => u -> UserRequest User   ModifyCurrentUser :: ModifyUserData -> UserRequest User   GetCurrentUserGuilds :: GetCurrentUserGuildsOptions -> UserRequest [Partial Guild]-  LeaveGuild :: HasID Guild g => g -> UserRequest ()-  CreateDM :: HasID User u => u -> UserRequest DMChannel+  LeaveGuild :: (HasID Guild g) => g -> UserRequest ()+  CreateDM :: (HasID User u) => u -> UserRequest DMChannel  baseRoute :: RouteBuilder _ baseRoute = mkRouteBuilder // S "users" // S "@me"

@@ -121,16 +121,16 @@ $(makeFieldLabelsNoPrefix ''ExecuteWebhookOptions)  data WebhookRequest a where-  CreateWebhook :: HasID Channel c => c -> CreateWebhookData -> WebhookRequest Webhook-  GetChannelWebhooks :: HasID Channel c => c -> WebhookRequest [Webhook]-  GetGuildWebhooks :: HasID Guild c => c -> WebhookRequest [Webhook]-  GetWebhook :: HasID Webhook w => w -> WebhookRequest Webhook-  GetWebhookToken :: HasID Webhook w => w -> Text -> WebhookRequest Webhook-  ModifyWebhook :: HasID Webhook w => w -> ModifyWebhookData -> WebhookRequest Webhook-  ModifyWebhookToken :: HasID Webhook w => w -> Text -> ModifyWebhookData -> WebhookRequest Webhook-  DeleteWebhook :: HasID Webhook w => w -> WebhookRequest ()-  DeleteWebhookToken :: HasID Webhook w => w -> Text -> WebhookRequest ()-  ExecuteWebhook :: HasID Webhook w => w -> Text -> ExecuteWebhookOptions -> WebhookRequest ()+  CreateWebhook :: (HasID Channel c) => c -> CreateWebhookData -> WebhookRequest Webhook+  GetChannelWebhooks :: (HasID Channel c) => c -> WebhookRequest [Webhook]+  GetGuildWebhooks :: (HasID Guild c) => c -> WebhookRequest [Webhook]+  GetWebhook :: (HasID Webhook w) => w -> WebhookRequest Webhook+  GetWebhookToken :: (HasID Webhook w) => w -> Text -> WebhookRequest Webhook+  ModifyWebhook :: (HasID Webhook w) => w -> ModifyWebhookData -> WebhookRequest Webhook+  ModifyWebhookToken :: (HasID Webhook w) => w -> Text -> ModifyWebhookData -> WebhookRequest Webhook+  DeleteWebhook :: (HasID Webhook w) => w -> WebhookRequest ()+  DeleteWebhookToken :: (HasID Webhook w) => w -> Text -> WebhookRequest ()+  ExecuteWebhook :: (HasID Webhook w) => w -> Text -> ExecuteWebhookOptions -> WebhookRequest ()  baseRoute :: Snowflake Webhook -> RouteBuilder _ baseRoute id = mkRouteBuilder // S "webhooks" // ID @Webhook & giveID id@@ -139,38 +139,51 @@   type Result (WebhookRequest a) = a    route (CreateWebhook (getID @Channel -> cid) _) =-    mkRouteBuilder // S "channels" // ID @Channel // S "webhooks"-      & giveID cid-      & buildRoute+    mkRouteBuilder+      // S "channels"+      // ID @Channel+      // S "webhooks"+        & giveID cid+        & buildRoute   route (GetChannelWebhooks (getID @Channel -> cid)) =-    mkRouteBuilder // S "channels" // ID @Channel // S "webhooks"-      & giveID cid-      & buildRoute+    mkRouteBuilder+      // S "channels"+      // ID @Channel+      // S "webhooks"+        & giveID cid+        & buildRoute   route (GetGuildWebhooks (getID @Guild -> gid)) =-    mkRouteBuilder // S "guilds" // ID @Guild // S "webhooks"-      & giveID gid-      & buildRoute+    mkRouteBuilder+      // S "guilds"+      // ID @Guild+      // S "webhooks"+        & giveID gid+        & buildRoute   route (GetWebhook (getID @Webhook -> wid)) =     baseRoute wid       & buildRoute   route (GetWebhookToken (getID @Webhook -> wid) t) =-    baseRoute wid // S t-      & buildRoute+    baseRoute wid+      // S t+        & buildRoute   route (ModifyWebhook (getID @Webhook -> wid) _) =     baseRoute wid       & buildRoute   route (ModifyWebhookToken (getID @Webhook -> wid) t _) =-    baseRoute wid // S t-      & buildRoute+    baseRoute wid+      // S t+        & buildRoute   route (DeleteWebhook (getID @Webhook -> wid)) =     baseRoute wid       & buildRoute   route (DeleteWebhookToken (getID @Webhook -> wid) t) =-    baseRoute wid // S t-      & buildRoute+    baseRoute wid+      // S t+        & buildRoute   route (ExecuteWebhook (getID @Webhook -> wid) t _) =-    baseRoute wid // S t-      & buildRoute+    baseRoute wid+      // S t+        & buildRoute    action (CreateWebhook _ o) = postWith' $ ReqBodyJson o   action (GetChannelWebhooks _) = getWith

@@ -24,16 +24,16 @@  makeSem ''InteractionEff -getInteractionID :: P.Member InteractionEff r => P.Sem r (Snowflake Interaction)+getInteractionID :: (P.Member InteractionEff r) => P.Sem r (Snowflake Interaction) getInteractionID = (^. #id) <$> getInteraction -getApplicationID :: P.Member InteractionEff r => P.Sem r (Snowflake Application)+getApplicationID :: (P.Member InteractionEff r) => P.Sem r (Snowflake Application) getApplicationID = (^. #applicationID) <$> getInteraction -getInteractionToken :: P.Member InteractionEff r => P.Sem r InteractionToken+getInteractionToken :: (P.Member InteractionEff r) => P.Sem r InteractionToken getInteractionToken = (^. #token) <$> getInteraction -getInteractionUser :: P.Member InteractionEff r => P.Sem r (Snowflake User)+getInteractionUser :: (P.Member InteractionEff r) => P.Sem r (Snowflake User) getInteractionUser = do   int <- getInteraction   let uid = int ^? #user % _Just % #id

@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}+ -- | Interaction related utilities module Calamity.Interactions.Utils (   respond,@@ -32,7 +34,7 @@ -} userLocalState ::   forall r s a.-  P.Member InteractionEff r =>+  (P.Member InteractionEff r) =>   -- | Initial state   s ->   P.Sem (P.State s ': r) a ->@@ -165,7 +167,7 @@         invoke $ CreateFollowupMessage applicationID interactionToken opts  -- | Defer an interaction and show a loading state, use @followUp@ later on-defer :: P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r => P.Sem r (Either RestError ())+defer :: (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r) => P.Sem r (Either RestError ()) defer = do   interactionID <- getInteractionID   interactionToken <- getInteractionToken@@ -174,14 +176,14 @@ {- | Defer an interaction and show an ephemeral loading state, use @followUp@  later on -}-deferEphemeral :: P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r => P.Sem r (Either RestError ())+deferEphemeral :: (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r) => P.Sem r (Either RestError ()) deferEphemeral = do   interactionID <- getInteractionID   interactionToken <- getInteractionToken   invoke $ CreateResponseDefer interactionID interactionToken True  -- | Defer operation-deferComponent :: P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r => P.Sem r (Either RestError ())+deferComponent :: (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r) => P.Sem r (Either RestError ()) deferComponent = do   interactionID <- getInteractionID   interactionToken <- getInteractionToken@@ -195,7 +197,7 @@   You should probably use this with 'Calamity.Interaction.View.runView' -}-pushModal :: P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r => Text -> [Component] -> P.Sem r (Either RestError ())+pushModal :: (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r) => Text -> [Component] -> P.Sem r (Either RestError ()) pushModal title c = do   -- we don't actually use the custom id of the modal. the custom ids of the   -- sub-components are enough to disambiguate

@@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}  module Calamity.Interactions.View (   ViewEff (..),@@ -62,7 +63,7 @@ -} data View a   = NilView a-  | SingView (forall g. RandomGen g => g -> (ViewComponent a, g))+  | SingView (forall g. (RandomGen g) => g -> (ViewComponent a, g))   | RowView (View a)   | forall x. MultView (View (x -> a)) (View x) @@ -92,7 +93,7 @@     'E.:$$: 'E.Text "Also, make sure you use lazy patterns: ~(a, b) instead of (a, b)"     'E.:$$: 'E.Text "Refer to https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/applicative_do.html" -instance E.TypeError MonadViewMessage => Monad View where+instance (E.TypeError MonadViewMessage) => Monad View where   (>>=) = undefined -- unreachable  data ExtractOkType@@ -296,7 +297,7 @@ -- componentIDS (C.TextInput' C.TextInput {customID}) = S.singleton customID  -- | Generate a 'ViewInstance' of a 'View' by filling in 'CustomID's with random values-instantiateView :: RandomGen g => g -> View a -> (ViewInstance a, g)+instantiateView :: (RandomGen g) => g -> View a -> (ViewInstance a, g) instantiateView g v =   case v of     NilView x -> (ViewInstance (const $ ExtractOk SomeExtracted x) [], g)@@ -332,7 +333,7 @@  views after a timeout. -} runView ::-  BotC r =>+  (BotC r) =>   -- | The initial view to render   View inp ->   -- | A function to send the rendered view (i.e. as a message or a modal)@@ -352,7 +353,7 @@  This function won't send the view, you should do that yourself -} runViewInstance ::-  BotC r =>+  (BotC r) =>   -- | An initial value to act as the value of @GetSendResponse@   --   -- If you just sent a message, probably pass that@@ -389,7 +390,7 @@      interpretView ::       forall r ret inp sendResp.-      P.Member (P.Embed IO) r =>+      (P.Member (P.Embed IO) r) =>       P.Sem (ViewEff ret inp sendResp ': r) () ->       P.Sem (P.State (Maybe ret, ViewInstance inp, sendResp) ': r) ()     interpretView =@@ -405,7 +406,7 @@      innerLoop ::       forall r ret inp sendResp.-      P.Members '[RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r =>+      (P.Members '[RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r) =>       sendResp ->       ViewInstance inp ->       STM.TQueue Interaction ->

@@ -12,7 +12,8 @@  import Calamity.Internal.Utils (unlessM, whenM) import Calamity.Types.Snowflake (HasID (getID), HasID', Snowflake)-import Control.Monad.State.Lazy (execState, when)+import Control.Monad (when)+import Control.Monad.State.Lazy (execState) import Data.Default.Class (Default (..)) import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as H@@ -44,9 +45,9 @@  type instance IxValue (BoundedStore a) = a -instance HasID' a => Ixed (BoundedStore a)+instance (HasID' a) => Ixed (BoundedStore a) -instance HasID' a => At (BoundedStore a) where+instance (HasID' a) => At (BoundedStore a) where   at k = lensVL $ \f m ->     let mv = getItem k m      in f mv <&> \case@@ -54,7 +55,7 @@           Just v -> addItem v m   {-# INLINE at #-} -addItem :: HasID' a => a -> BoundedStore a -> BoundedStore a+addItem :: (HasID' a) => a -> BoundedStore a -> BoundedStore a addItem m = execState $ do   unlessM (H.member (getID m) <$> use #items) $ do     #itemQueue %= DQ.cons (getID m)

@@ -9,10 +9,10 @@ class GCtorName f where   gctorName :: f a -> String -instance Constructor c => GCtorName (C1 c f) where+instance (Constructor c) => GCtorName (C1 c f) where   gctorName = conName -instance GCtorName f => GCtorName (D1 d f) where+instance (GCtorName f) => GCtorName (D1 d f) where   gctorName (M1 a) = gctorName a  instance (GCtorName f, GCtorName g) => GCtorName (f :+: g) where

@@ -17,7 +17,7 @@  P.makeSem ''LocalWriter -runLocalWriter :: Monoid o => P.Sem (LocalWriter o ': r) a -> P.Sem r (o, a)+runLocalWriter :: (Monoid o) => P.Sem (LocalWriter o ': r) a -> P.Sem r (o, a) runLocalWriter =   P.runState mempty     . P.reinterpretH

@@ -9,13 +9,13 @@ import Polysemy qualified as P import Polysemy.Final qualified as P -runSemToIO :: forall r a. P.Member (P.Final IO) r => P.Sem r a -> P.Sem r (IO (Maybe a))+runSemToIO :: forall r a. (P.Member (P.Final IO) r) => P.Sem r a -> P.Sem r (IO (Maybe a)) runSemToIO m = P.withStrategicToFinal $ do   m' <- P.runS m   ins <- P.getInspectorS   P.liftS $ pure (P.inspect ins <$> m') -bindSemToIO :: forall r p a. P.Member (P.Final IO) r => (p -> P.Sem r a) -> P.Sem r (p -> IO (Maybe a))+bindSemToIO :: forall r p a. (P.Member (P.Final IO) r) => (p -> P.Sem r a) -> P.Sem r (p -> IO (Maybe a)) bindSemToIO m = P.withStrategicToFinal $ do   istate <- P.getInitialStateS   m' <- P.bindS m

@@ -68,7 +68,7 @@ empty = SnowflakeMap SH.empty {-# INLINEABLE empty #-} -singleton :: HasID' a => a -> SnowflakeMap a+singleton :: (HasID' a) => a -> SnowflakeMap a singleton v = SnowflakeMap $ SH.singleton (getID v) v {-# INLINEABLE singleton #-} @@ -98,11 +98,11 @@  infixl 9 ! -insert :: HasID' a => a -> SnowflakeMap a -> SnowflakeMap a+insert :: (HasID' a) => a -> SnowflakeMap a -> SnowflakeMap a insert v = overSM $ SH.insert (getID v) v {-# INLINEABLE insert #-} -insertWith :: HasID' a => (a -> a -> a) -> a -> SnowflakeMap a -> SnowflakeMap a+insertWith :: (HasID' a) => (a -> a -> a) -> a -> SnowflakeMap a -> SnowflakeMap a insertWith f v = overSM $ SH.insertWith f (getID v) v {-# INLINEABLE insertWith #-} @@ -146,7 +146,7 @@ mapWithKey f = overSM $ coerceSnowflakeMap . SH.mapWithKey f {-# INLINEABLE mapWithKey #-} -traverseWithKey :: Applicative f => (Snowflake a1 -> a1 -> f a2) -> SnowflakeMap a1 -> f (SnowflakeMap a2)+traverseWithKey :: (Applicative f) => (Snowflake a1 -> a1 -> f a2) -> SnowflakeMap a1 -> f (SnowflakeMap a2) traverseWithKey f = fmap (SnowflakeMap . coerceSnowflakeMap) . SH.traverseWithKey f . unSnowflakeMap {-# INLINEABLE traverseWithKey #-} @@ -214,11 +214,11 @@ toList = SH.toList . unSnowflakeMap {-# INLINEABLE toList #-} -fromList :: HasID' a => [a] -> SnowflakeMap a+fromList :: (HasID' a) => [a] -> SnowflakeMap a fromList = SnowflakeMap . SH.fromList . Prelude.map (\v -> (getID v, v)) {-# INLINEABLE fromList #-} -fromListWith :: HasID' a => (a -> a -> a) -> [a] -> SnowflakeMap a+fromListWith :: (HasID' a) => (a -> a -> a) -> [a] -> SnowflakeMap a fromListWith f = SnowflakeMap . SH.fromListWith f . Prelude.map (\v -> (getID v, v)) {-# INLINEABLE fromListWith #-} @@ -227,6 +227,6 @@     parsed <- traverse parseJSON l     pure . Calamity.Internal.SnowflakeMap.fromList . F.toList $ parsed -instance ToJSON a => ToJSON (SnowflakeMap a) where+instance (ToJSON a) => ToJSON (SnowflakeMap a) where   toJSON = toJSON . elems   toEncoding = toEncoding . elems

@@ -1,3 +1,6 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}+ -- | Internal utilities and instances module Calamity.Internal.Utils (   whileMFinalIO,@@ -46,7 +49,7 @@  This means Polysemy.Error won't work to break the loop, etc.  Instead, Error/Alternative will just result in the loop quitting. -}-whileMFinalIO :: P.Member (P.Final IO) r => P.Sem r Bool -> P.Sem r ()+whileMFinalIO :: (P.Member (P.Final IO) r) => P.Sem r Bool -> P.Sem r () whileMFinalIO action = do   action' <- runSemToIO action   P.embedFinal $ go action'@@ -64,7 +67,7 @@  This means Polysemy.Error won't work to break the loop, etc.  Instead, Error/Alternative will just result in another loop. -}-untilJustFinalIO :: P.Member (P.Final IO) r => P.Sem r (Maybe a) -> P.Sem r a+untilJustFinalIO :: (P.Member (P.Final IO) r) => P.Sem r (Maybe a) -> P.Sem r a untilJustFinalIO action = do   action' <- runSemToIO action   P.embedFinal $ go action'@@ -77,16 +80,16 @@         _ ->           go action' -whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()+whenJust :: (Applicative m) => Maybe a -> (a -> m ()) -> m () whenJust = flip $ maybe (pure ()) -whenM :: Monad m => m Bool -> m () -> m ()+whenM :: (Monad m) => m Bool -> m () -> m () whenM p m =   p >>= \case     True -> m     False -> pure () -unlessM :: Monad m => m Bool -> m () -> m ()+unlessM :: (Monad m) => m Bool -> m () -> m () unlessM = whenM . (not <$>)  lastMaybe :: Maybe a -> Maybe a -> Maybe a@@ -114,18 +117,18 @@  infixl 4 <<*>> -(<.>) :: Functor f => (a -> b) -> (c -> f a) -> (c -> f b)+(<.>) :: (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 :: (P.Member LogEff r) => Text -> P.Sem r () debug = Di.debug -info :: P.Member LogEff r => Text -> P.Sem r ()+info :: (P.Member LogEff r) => Text -> P.Sem r () info = Di.info -error :: P.Member LogEff r => Text -> P.Sem r ()+error :: (P.Member LogEff r) => Text -> P.Sem r () error = Di.error  swap :: (a, b) -> (b, a)@@ -161,17 +164,28 @@   | NotNull a   deriving (Show) -instance Aeson.FromJSON a => Aeson.FromJSON (MaybeNull a) where+instance (Aeson.FromJSON a) => Aeson.FromJSON (MaybeNull a) where   parseJSON Aeson.Null = pure WasNull   parseJSON x = NotNull <$> Aeson.parseJSON x -instance Aeson.ToJSON a => Aeson.ToJSON (MaybeNull a) where+instance (Aeson.ToJSON a) => Aeson.ToJSON (MaybeNull a) where   toJSON WasNull = Aeson.Null   toJSON (NotNull x) = Aeson.toJSON x    toEncoding WasNull = null_   toEncoding (NotNull x) = Aeson.toEncoding x +#if MIN_VERSION_aeson(2,2,0)+(.?=) :: (Aeson.ToJSON v, Aeson.KeyValue e kv) => Aeson.Key -> Maybe v -> Maybe kv+k .?= Just v = Just (k Aeson..= v)+_ .?= Nothing = Nothing++(.=) :: (Aeson.ToJSON v, Aeson.KeyValue e kv) => Aeson.Key -> v -> Maybe kv+k .= v = Just (k Aeson..= v)++class CalamityToJSON' a where+  toPairs :: Aeson.KeyValue kv => a -> [Maybe kv]+#else (.?=) :: (Aeson.ToJSON v, Aeson.KeyValue kv) => Aeson.Key -> Maybe v -> Maybe kv k .?= Just v = Just (k Aeson..= v) _ .?= Nothing = Nothing@@ -181,9 +195,10 @@  class CalamityToJSON' a where   toPairs :: Aeson.KeyValue kv => a -> [Maybe kv]+#endif  newtype CalamityToJSON a = CalamityToJSON a -instance CalamityToJSON' a => Aeson.ToJSON (CalamityToJSON a) where+instance (CalamityToJSON' a) => Aeson.ToJSON (CalamityToJSON a) where   toJSON (CalamityToJSON x) = Aeson.object . catMaybes . toPairs $ x   toEncoding (CalamityToJSON x) = Aeson.pairs . mconcat . catMaybes . toPairs $ x

@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}+ -- | Things that can be fetched from the discord CDN module Calamity.Types.CDNAsset (   CDNAsset (..),

@@ -13,7 +13,7 @@ import Optics.TH import TextShow.TH -fuseTup2 :: Monad f => (f a, f b) -> f (a, b)+fuseTup2 :: (Monad f) => (f a, f b) -> f (a, b) fuseTup2 (a, b) = do   !a' <- a   !b' <- b

@@ -346,26 +346,64 @@ instance Semigroup EmbedFooter where   l <> r =     l-      & #text %~ (<> (r ^. #text))-      & #iconUrl %~ getLast . (<> Last (r ^. #iconUrl)) . Last-      & #proxyIconUrl %~ getLast . (<> Last (r ^. #proxyIconUrl)) . Last+      & #text+      %~ (<> (r ^. #text))+      & #iconUrl+      %~ getLast+      . (<> Last (r ^. #iconUrl))+      . Last+      & #proxyIconUrl+      %~ getLast+      . (<> Last (r ^. #proxyIconUrl))+      . Last  instance Semigroup Embed where   l <> r =     l-      & #title %~ (<> (r ^. #title))-      & #type_ %~ getLast . (<> Last (r ^. #type_)) . Last-      & #description %~ (<> (r ^. #description))-      & #url %~ getLast . (<> Last (r ^. #url)) . Last-      & #timestamp %~ getLast . (<> Last (r ^. #timestamp)) . Last-      & #color %~ getLast . (<> Last (r ^. #color)) . Last-      & #footer %~ (<> (r ^. #footer))-      & #image %~ getLast . (<> Last (r ^. #image)) . Last-      & #thumbnail %~ getLast . (<> Last (r ^. #thumbnail)) . Last-      & #video %~ getLast . (<> Last (r ^. #video)) . Last-      & #provider %~ getLast . (<> Last (r ^. #provider)) . Last-      & #author %~ getLast . (<> Last (r ^. #author)) . Last-      & #fields %~ (<> (r ^. #fields))+      & #title+      %~ (<> (r ^. #title))+      & #type_+      %~ getLast+      . (<> Last (r ^. #type_))+      . Last+      & #description+      %~ (<> (r ^. #description))+      & #url+      %~ getLast+      . (<> Last (r ^. #url))+      . Last+      & #timestamp+      %~ getLast+      . (<> Last (r ^. #timestamp))+      . Last+      & #color+      %~ getLast+      . (<> Last (r ^. #color))+      . Last+      & #footer+      %~ (<> (r ^. #footer))+      & #image+      %~ getLast+      . (<> Last (r ^. #image))+      . Last+      & #thumbnail+      %~ getLast+      . (<> Last (r ^. #thumbnail))+      . Last+      & #video+      %~ getLast+      . (<> Last (r ^. #video))+      . Last+      & #provider+      %~ getLast+      . (<> Last (r ^. #provider))+      . Last+      & #author+      %~ getLast+      . (<> Last (r ^. #author))+      . Last+      & #fields+      %~ (<> (r ^. #fields))  instance Monoid Embed where   mempty = def

@@ -141,7 +141,7 @@ class Tellable a where   getChannel :: (BotC r, P.Member (P.Error RestError) r) => a -> P.Sem r (Snowflake Channel) -runToMessage :: ToMessage a => a -> CreateMessageOptions+runToMessage :: (ToMessage a) => a -> CreateMessageOptions runToMessage = flip appEndo def . intoMsg  {- | Send a message to something that is messageable

@@ -24,9 +24,9 @@   --   -- If it existed in the cache then it is returned from there, otherwise we   -- fetch from HTTP and update the cache on success.-  upgrade :: BotC r => ids -> P.Sem r (Maybe a)+  upgrade :: (BotC r) => ids -> P.Sem r (Maybe a) -maybeToAlt :: Alternative f => Maybe a -> f a+maybeToAlt :: (Alternative f) => Maybe a -> f a maybeToAlt (Just x) = pure x maybeToAlt Nothing = empty @@ -58,7 +58,7 @@         Right g <- invoke $ H.GetGuild gid         pure g -insertChannel :: BotC r => Channel -> P.Sem r ()+insertChannel :: (BotC r) => Channel -> P.Sem r () insertChannel (DMChannel' dm) = setDM dm insertChannel (GuildChannel' ch) =   updateGuild (getID ch) (#channels % at (getID @GuildChannel ch) ?~ ch)

@@ -44,7 +44,7 @@ import Optics import TextShow (TextShow (showt)) -zws :: IsString s => s+zws :: (IsString s) => s zws = fromString "\x200b"  -- | Replaces all occurences of @\`\`\`@ with @\`\<zws\>\`\<zws\>\`@

@@ -1,5 +1,10 @@ # Changelog for Calamity +## 0.11.0.0+++ Added support for Aeson 2.2 @Miezhiko++ Support MTL 2.3+ @Miezhiko+ ## 0.10.0.0  + Updated `CreateMessageAttachment.content` to be a `Network.HTTP.Client.RequestBody`

@@ -1,6 +1,6 @@ cabal-version:      2.0 name:               calamity-version:            0.10.0.0+version:            0.11.0.0 synopsis:           A library for writing discord bots in haskell description:   Please see the README on GitHub at <https://github.com/simmsb/calamity#readme>@@ -14,7 +14,7 @@ license:            MIT license-file:       LICENSE build-type:         Simple-tested-with:        GHC ==9.4.4+tested-with:        GHC ==9.6.4 extra-source-files:   ChangeLog.md   README.md@@ -130,7 +130,6 @@    hs-source-dirs:     ./   default-extensions:-    NoMonomorphismRestriction     AllowAmbiguousTypes     BangPatterns     BinaryLiterals@@ -162,6 +161,7 @@     MultiParamTypeClasses     MultiWayIf     NamedFieldPuns+    NoMonomorphismRestriction     OverloadedLabels     OverloadedStrings     PartialTypeSignatures@@ -182,20 +182,17 @@     UndecidableInstances     ViewPatterns -  ghc-options:-    -fplugin=Polysemy.Plugin -funbox-strict-fields -Wall-    -fno-warn-name-shadowing-+  ghc-options:        -funbox-strict-fields -Wall -fno-warn-name-shadowing   build-depends:-      aeson                 >=2.0     && <2.2+      aeson                 >=2.1     && <2.3     , aeson-optics          >=1.2     && <2     , async                 >=2.2     && <3     , base                  >=4.13    && <5-    , bytestring            >=0.10    && <0.12+    , bytestring            >=0.10    && <0.13     , calamity-commands     >=0.4     && <0.5     , colour                >=2.3.5   && <2.4     , concurrent-extra      >=0.7     && <0.8-    , containers            >=0.6     && <0.7+    , containers            >=0.6     && <0.8     , crypton-connection    >=0.2.6   && <0.4     , crypton-x509-system   >=1.6.6   && <1.7     , data-default-class    >=0.1     && <0.2@@ -208,7 +205,7 @@     , exceptions            >=0.10    && <0.11     , focus                 >=1.0     && <2     , hashable              >=1.2     && <2-    , http-api-data         >=0.4.3   && <0.6+    , http-api-data         >=0.4.3   && <0.7     , http-client           >=0.5     && <0.8     , http-date             >=0.0.8   && <0.1     , http-types            >=0.12    && <0.13@@ -226,15 +223,15 @@     , stm                   >=2.5     && <3     , stm-chans             >=3.0     && <4     , stm-containers        >=1.1     && <2-    , text                  >=1.2     && <2.1+    , text                  >=1.2     && <2.2     , text-show             >=3.8     && <4-    , time                  >=1.8     && <1.13-    , tls                   >=1.7     && <2+    , time                  >=1.8     && <1.15+    , tls                   >=1.7     && <3     , typerep-map           >=0.5     && <0.7     , unagi-chan            >=0.4     && <0.5     , unboxing-vector       >=0.2     && <0.3     , unordered-containers  >=0.2     && <0.3     , vector                >=0.12    && <0.14-    , websockets            >=0.12    && <0.13+    , websockets            >=0.13    && <0.14    default-language:   Haskell2010