calamity 0.1.30.2 → 0.1.30.3

raw patch · 21 files changed

+1352/−1067 lines, 21 filesdep ~calamity-commandsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: calamity-commands

API changes (from Hackage documentation)

Files

• Calamity/Client/Client.hs +716/−752
• Calamity/Client/Types.hs +5/−5
• Calamity/Commands/Context.hs +6/−0
• Calamity/Gateway/DispatchEvents.hs +172/−170
• Calamity/Gateway/Intents.hs +48/−42
• Calamity/Gateway/Shard.hs +1/−1
• Calamity/HTTP/Internal/Route.hs +1/−1
• Calamity/Internal/AesonThings.hs +1/−1
• Calamity/Internal/Updateable.hs +102/−73
• Calamity/Internal/Utils.hs +23/−0
• Calamity/Types/Model/Channel/ChannelType.hs +8/−9
• Calamity/Types/Model/Channel/Component.hs +120/−0
• Calamity/Types/Model/Channel/Message.hs +8/−4
• Calamity/Types/Model/Channel/Message.hs-boot +0/−1
• Calamity/Types/Model/Channel/UpdatedMessage.hs +25/−3
• Calamity/Types/Model/Guild/AuditLog.hs +1/−1
• Calamity/Types/Model/Interaction.hs +101/−0
• Calamity/Types/Model/Presence/Activity.hs +1/−1
• Calamity/Types/Snowflake.hs +1/−1
• ChangeLog.md +8/−0
• calamity.cabal +4/−2

@@ -2,755 +2,719 @@  -- | The client module Calamity.Client.Client (-  react,-  runBotIO,-  runBotIO',-  stopBot,-  sendPresence,-  events,-  fire,-  waitUntil,-  waitUntilM,-  CalamityEvent (Dispatch, ShutDown),-  customEvt,-) where--import Calamity.Cache.Eff-import Calamity.Client.ShardManager-import Calamity.Client.Types-import Calamity.Gateway.DispatchEvents-import Calamity.Gateway.Intents-import Calamity.Gateway.Types-import Calamity.HTTP.Internal.Ratelimit-import Calamity.Internal.ConstructorName-import Calamity.Internal.RunIntoIO-import qualified Calamity.Internal.SnowflakeMap as SM-import Calamity.Internal.UnixTimestamp-import Calamity.Internal.Updateable-import Calamity.Internal.Utils-import Calamity.Metrics.Eff-import Calamity.Types.LogEff-import Calamity.Types.Model.Channel-import Calamity.Types.Model.Guild-import Calamity.Types.Model.Presence (Presence (..))-import Calamity.Types.Model.User-import qualified Calamity.Types.Model.Voice as V-import Calamity.Types.Snowflake-import Calamity.Types.Token-import Control.Concurrent.Chan.Unagi-import Control.Concurrent.MVar-import Control.Concurrent.STM-import Control.Exception (SomeException)-import Control.Lens hiding ((<.>))-import Control.Monad-import Data.Default.Class-import Data.Dynamic-import Data.Foldable-import Data.Generics.Product.Subtype-import Data.IORef-import Data.Maybe-import Data.Proxy-import qualified Data.Text as S-import Data.Time.Clock.POSIX-import qualified Df1-import qualified Di.Core as DC-import qualified DiPolysemy as Di-import qualified Polysemy as P-import qualified Polysemy.Async as P-import qualified Polysemy.AtomicState as P-import qualified Polysemy.Error as P-import qualified Polysemy.Fail as P-import qualified Polysemy.Reader as P-import qualified Polysemy.Resource as P-import PyF-import TextShow (TextShow (showt))--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-  end <- P.embed getPOSIXTime-  let duration = fromRational . toRational $ end - start-  pure (duration, res)---newClient :: Token -> Maybe (DC.Di Df1.Level Df1.Path Df1.Message) -> IO Client-newClient token initialDi = do-  shards'        <- newTVarIO []-  numShards'     <- newEmptyMVar-  rlState'       <- newRateLimitState-  (inc, outc)    <- newChan-  ehidCounter    <- newIORef 0--  pure $ Client shards'-                numShards'-                token-                rlState'-                inc-                outc-                ehidCounter-                initialDi---- | Create a bot, run your setup action, and then loop until the bot closes.-runBotIO :: forall r a.-         (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff, LogEff] r, Typeable (SetupEff r))-         => Token-         -> Intents-         -- ^ The intents the bot should use-         -> P.Sem (SetupEff r) a-         -> P.Sem r (Maybe StartupError)-runBotIO token intents = runBotIO' token intents Nothing--resetDi :: BotC r => P.Sem r a -> P.Sem r a-resetDi m = do-  initialDi <- P.asks (^. #initialDi)-  Di.local (flip fromMaybe initialDi) m---- | Create a bot, run your setup action, and then loop until the bot closes.------ This version allows you to specify the initial status, and intents.-runBotIO' :: forall r a.-          (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff, LogEff] r, Typeable (SetupEff r))-          => Token-          -> Intents-          -- ^ The intents the bot should use-          -> Maybe StatusUpdateData-          -- ^ The initial status to send to the gateway-          -> P.Sem (SetupEff r) a-          -> P.Sem r (Maybe StartupError)-runBotIO' token intents status setup = do-  initialDi <- Di.fetch-  client <- P.embed $ newClient token initialDi-  handlers <- P.embed $ newTVarIO def-  P.asyncToIOFinal . P.runAtomicStateTVar handlers . P.runReader client . Di.push "calamity" $ do-    void $ Di.push "calamity-setup" setup-    r <- shardBot status intents-    case r of-      Left e  -> pure (Just e)-      Right _ -> do-        Di.push "calamity-loop" clientLoop-        Di.push "calamity-stop" finishUp-        pure Nothing---- | 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--- parameters the event handlers they receive.------ You'll probably want @TypeApplications@ and need @DataKinds@ enabled to--- specify the type of @s@.------ ==== Examples------ Reacting to every message:------ @--- 'react' @\''MessageCreateEvt' '$' \msg -> 'print' '$' "Got message: " '<>' 'show' msg--- @------ Reacting to a custom event:------ @--- data MyCustomEvt = MyCustomEvt 'Data.Text.Text' 'Message'------ 'react' @(\''CustomEvt' MyCustomEvt) $ \\(MyCustomEvt s m) ->---    'void' $ 'Calamity.Types.Tellable.tell' @'Data.Text.Text' m ("Somebody told me to tell you about: " '<>' s)--- @------ ==== Notes------ This function is pretty bad for giving nasty type errors,--- since if something doesn't match then 'EHType' might not get substituted,--- which will result in errors about parameter counts mismatching.-react :: forall (s :: EventType) r.-      (BotC r, ReactConstraints s)-      => (EHType s -> (P.Sem r) ())-      -> P.Sem r (P.Sem r ())-react handler = do-  handler' <- bindSemToIO handler-  ehidC <- P.asks (^. #ehidCounter)-  id' <- P.embed $ atomicModifyIORef ehidC (\i -> (i + 1, i))-  let handlers = makeEventHandlers (Proxy @s) id' (const () <.> handler')-  P.atomicModify (handlers <>)-  pure $ removeHandler @s id'--removeHandler :: forall (s :: EventType) r. (BotC r, RemoveEventHandler s) => Integer -> P.Sem r ()-removeHandler id' = P.atomicModify (removeEventHandler (Proxy @s) id')---- | Fire an event that the bot will then handle.------ ==== Examples------ Firing an event named \"my-event\":------ @--- 'fire' '$' 'customEvt' @"my-event" ("aha" :: 'Data.Text.Text', msg)--- @-fire :: BotC r => CalamityEvent -> P.Sem r ()-fire e = do-  inc <- P.asks (^. #eventsIn)-  P.embed $ writeChan inc e---- | Build a Custom CalamityEvent------ The type of @a@ must match up with the event handler you want to receive it.------ ==== Examples------ @--- 'customEvt' (MyCustomEvent "lol")--- @-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 = do-  inc <- P.asks (^. #eventsIn)-  P.embed $ dupChan inc---- | Wait until an event satisfying a condition happens, then returns it's--- parameters.------ The check function for this command is pure unlike 'waitUntilM'------ This is what it would look like with @s ~ \''MessageCreateEvt'@:------ @--- 'waitUntil' :: ('Message' -> 'Bool') -> 'P.Sem' r 'Message'--- @------ And for @s ~ \''MessageUpdateEvt'@:------ @--- 'waitUntil' :: (('Message', 'Message') -> 'Bool') -> 'P.Sem' r ('Message', 'Message')--- @------ ==== Examples------ Waiting for a message containing the text \"hi\":------ @--- f = do msg \<\- 'waitUntil' @\''MessageCreateEvt' (\\m -> 'Data.Text.Lazy.isInfixOf' "hi" $ m ^. #content)---        print $ msg ^. #content--- @-waitUntil-  :: forall (s :: EventType) r.-  ( BotC r, ReactConstraints s)-  => (EHType s -> Bool)-  -> P.Sem r (EHType s)-waitUntil f = P.resourceToIOFinal $ do-  result <- P.embed newEmptyMVar-  P.bracket (P.raise $ react @s (checker result))-            P.raise-            (const . P.embed $ takeMVar result)-  where-    checker :: MVar (EHType s) -> EHType s -> P.Sem r ()-    checker result args = do-      when (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.-  ( BotC r, ReactConstraints s)-  => (EHType s -> P.Sem r Bool)-  -> P.Sem r (EHType s)-waitUntilM f = P.resourceToIOFinal $ do-  result <- P.embed newEmptyMVar-  P.bracket (P.raise $ react @s (checker result))-            P.raise-            (const . P.embed $ takeMVar result)-  where-    checker :: MVar (EHType s) -> EHType s -> P.Sem r ()-    checker result args = do-      res <- f args-      when res $ do-        P.embed $ putMVar result args---- | Set the bot's presence on all shards.-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 = do-  debug "stopping bot"-  inc <- P.asks (^. #eventsIn)-  P.embed $ writeChan inc ShutDown--finishUp :: BotC r => P.Sem r ()-finishUp = do-  debug "finishing up"-  shards <- P.asks (^. #shards) >>= P.embed . readTVarIO-  for_ shards $ \(inc, _) ->-    P.embed $ writeChan inc ShutDownShard-  for_ shards $ \(_, shardThread) -> P.await shardThread-  debug "bot has stopped"---- | main loop of the client, handles fetching the next event, processing the--- event and invoking it's handler functions-clientLoop :: BotC r => P.Sem r ()-clientLoop = do-  outc <- P.asks (^. #eventsOut)-  whileMFinalIO $ do-    !evt' <- P.embed $ readChan outc-    case evt' of-      Dispatch !sid !evt -> handleEvent sid evt >> pure True-      Custom d           -> handleCustomEvent d >> pure True-      ShutDown           -> pure False-  debug "leaving client loop"--handleCustomEvent :: forall a r. (Typeable a, BotC r) => a -> P.Sem r ()-handleCustomEvent d = do-  eventHandlers <- P.atomicGet--  let handlers = getCustomEventHandlers @a eventHandlers--  for_ handlers (\h -> P.async . P.embed $ h d)--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 [fmt|got exception: {e:s}|]--handleEvent :: BotC r => Int -> DispatchData -> P.Sem r ()-handleEvent shardID data' = do-  debug "handling an event"-  eventHandlers <- P.atomicGet-  actions <- P.runFail $ do-    evtCounter <- registerCounter "events_received" [("type", S.pack $ ctorName data'), ("shard", showt shardID)]-    void $ addCounter 1 evtCounter-    cacheUpdateHisto <- registerHistogram "cache_update" mempty [10, 20..100]-    (time, res) <- timeA $ resetDi $ handleEvent' eventHandlers data'-    void $ observeHistogram time cacheUpdateHisto-    pure res--  eventHandleHisto <- registerHistogram "event_handle" mempty [10, 20..100]--  case actions of-    Right actions -> for_ actions $ \action -> P.async $ do-      (time, _) <- timeA . catchAllLogging $ P.embed action-      void $ observeHistogram time eventHandleHisto-    -- pattern match failures are usually stuff like events for uncached guilds, etc-    Left err      -> debug [fmt|Failed handling actions for event: {err:s}|]--handleEvent' :: BotC r-              => EventHandlers-              -> DispatchData-              -> P.Sem (P.Fail ': r) [IO ()]-handleEvent' eh evt@(Ready rd@ReadyData {}) = do-  updateCache evt-  pure $ map ($ rd) (getEventHandlers @'ReadyEvt eh)--handleEvent' _ Resumed = pure []--handleEvent' eh evt@(ChannelCreate (DMChannel' chan)) = do-  updateCache evt-  Just newChan <- DMChannel' <<$>> getDM (getID chan)-  pure $ map ($ newChan) (getEventHandlers @'ChannelCreateEvt eh)--handleEvent' eh evt@(ChannelCreate (GuildChannel' chan)) = do-  updateCache evt-  Just guild <- getGuild (getID chan)-  Just newChan <- pure $ GuildChannel' <$> guild ^. #channels . at (getID chan)-  pure $ map ($ newChan) (getEventHandlers @'ChannelCreateEvt eh)--handleEvent' eh evt@(ChannelUpdate (DMChannel' chan)) = do-  Just oldChan <- DMChannel' <<$>> getDM (getID chan)-  updateCache evt-  Just newChan <- DMChannel' <<$>> getDM (getID chan)-  pure $ map ($ (oldChan, newChan)) (getEventHandlers @'ChannelUpdateEvt eh)--handleEvent' eh evt@(ChannelUpdate (GuildChannel' chan)) = do-  Just oldGuild <- getGuild (getID chan)-  Just oldChan <- pure $ GuildChannel' <$> oldGuild ^. #channels . at (getID chan)-  updateCache evt-  Just newGuild <- getGuild (getID chan)-  Just newChan <- pure $ GuildChannel' <$> newGuild ^. #channels . at (getID chan)-  pure $ map ($ (oldChan, newChan)) (getEventHandlers @'ChannelUpdateEvt eh)--handleEvent' eh evt@(ChannelDelete (GuildChannel' chan)) = do-  Just oldGuild <- getGuild (getID chan)-  Just oldChan <- pure $ GuildChannel' <$> oldGuild ^. #channels . at (getID chan)-  updateCache evt-  pure $ map ($ oldChan) (getEventHandlers @'ChannelDeleteEvt eh)--handleEvent' eh evt@(ChannelDelete (DMChannel' chan)) = do-  Just oldChan <- DMChannel' <<$>> getDM (getID chan)-  updateCache evt-  pure $ map ($ oldChan) (getEventHandlers @'ChannelDeleteEvt eh)---- handleEvent' eh evt@(ChannelPinsUpdate ChannelPinsUpdateData { channelID, lastPinTimestamp }) = do---   chan <- (GuildChannel' <$> os ^? #channels . at (coerceSnowflake channelID) . _Just)---     <|> (DMChannel' <$> os ^? #dms . at (coerceSnowflake channelID) . _Just)---   pure $ map (\f -> f chan lastPinTimestamp) (getEventHandlers @"channelpinsupdate" eh)--handleEvent' eh evt@(GuildCreate guild) = do-  isNew <- not <$> isUnavailableGuild (getID guild)-  updateCache evt-  Just guild <- getGuild (getID guild)-  pure $ map ($ (guild, (if isNew then GuildCreateNew else GuildCreateAvailable)))-    (getEventHandlers @'GuildCreateEvt eh)--handleEvent' eh evt@(GuildUpdate guild) = do-  Just oldGuild <- getGuild (getID guild)-  updateCache evt-  Just newGuild <- getGuild (getID guild)-  pure $ map ($ (oldGuild, newGuild)) (getEventHandlers @'GuildUpdateEvt eh)---- NOTE: Guild will be deleted in the new cache if unavailable was false-handleEvent' eh evt@(GuildDelete UnavailableGuild { id, unavailable }) = do-  Just oldGuild <- getGuild id-  updateCache evt-  pure $ map ($ (oldGuild, (if unavailable then GuildDeleteUnavailable else GuildDeleteRemoved)))-    (getEventHandlers @'GuildDeleteEvt eh)--handleEvent' eh evt@(GuildBanAdd BanData { guildID, user }) = do-  Just guild <- getGuild guildID-  updateCache evt-  pure $ map ($ (guild, user)) (getEventHandlers @'GuildBanAddEvt eh)--handleEvent' eh evt@(GuildBanRemove BanData { guildID, user }) = do-  Just guild <- getGuild guildID-  updateCache evt-  pure $ map ($ (guild, user)) (getEventHandlers @'GuildBanRemoveEvt eh)---- NOTE: we fire this event using the guild data with old emojis-handleEvent' eh evt@(GuildEmojisUpdate GuildEmojisUpdateData { guildID, emojis }) = do-  Just guild <- getGuild guildID-  updateCache evt-  pure $ map ($ (guild, emojis)) (getEventHandlers @'GuildEmojisUpdateEvt eh)--handleEvent' eh evt@(GuildIntegrationsUpdate GuildIntegrationsUpdateData { guildID }) = do-  updateCache evt-  Just guild <- getGuild guildID-  pure $ map ($ guild) (getEventHandlers @'GuildIntegrationsUpdateEvt eh)--handleEvent' eh evt@(GuildMemberAdd member) = do-  updateCache evt-  Just guild <- getGuild (getID member)-  Just member <- pure $ guild ^. #members . at (getID member)-  pure $ map ($ member) (getEventHandlers @'GuildMemberAddEvt eh)--handleEvent' eh evt@(GuildMemberRemove GuildMemberRemoveData { user, guildID }) = do-  Just guild <- getGuild guildID-  Just member <- pure $ guild ^. #members . at (getID user)-  updateCache evt-  pure $ map ($ member) (getEventHandlers @'GuildMemberRemoveEvt eh)--handleEvent' eh evt@(GuildMemberUpdate GuildMemberUpdateData { user, guildID }) = do-  Just oldGuild <- getGuild guildID-  Just oldMember <- pure $ oldGuild ^. #members . at (getID user)-  updateCache evt-  Just newGuild <- getGuild guildID-  Just newMember <- pure $ newGuild ^. #members . at (getID user)-  pure $ map ($ (oldMember, newMember)) (getEventHandlers @'GuildMemberUpdateEvt eh)--handleEvent' eh evt@(GuildMembersChunk GuildMembersChunkData { members, guildID }) = do-  updateCache evt-  Just guild <- getGuild guildID-  let memberIDs = map (getID @Member) members-  let members' = catMaybes $ map (\mid -> guild ^. #members . at mid) memberIDs-  pure $ map ($ (guild, members')) (getEventHandlers @'GuildMembersChunkEvt eh)--handleEvent' eh evt@(GuildRoleCreate GuildRoleData { guildID, role }) = do-  updateCache evt-  Just guild <- getGuild guildID-  Just role' <- pure $ guild ^. #roles . at (getID role)-  pure $ map ($ (guild, role')) (getEventHandlers @'GuildRoleCreateEvt eh)--handleEvent' eh evt@(GuildRoleUpdate GuildRoleData { guildID, role }) = do-  Just oldGuild <- getGuild guildID-  Just oldRole <- pure $ oldGuild ^. #roles . at (getID role)-  updateCache evt-  Just newGuild <- getGuild guildID-  Just newRole <- pure $ newGuild ^. #roles . at (getID role)-  pure $ map ($ (newGuild, oldRole, newRole)) (getEventHandlers @'GuildRoleUpdateEvt eh)--handleEvent' eh evt@(GuildRoleDelete GuildRoleDeleteData { guildID, roleID }) = do-  Just guild <- getGuild guildID-  Just role <- pure $ guild ^. #roles . at roleID-  updateCache evt-  pure $ map ($ (guild, role)) (getEventHandlers @'GuildRoleDeleteEvt eh)--handleEvent' eh (InviteCreate d) = do-  pure $ map ($ d) (getEventHandlers @'InviteCreateEvt eh)--handleEvent' eh (InviteDelete d) = do-  pure $ map ($ d) (getEventHandlers @'InviteDeleteEvt eh)--handleEvent' eh evt@(MessageCreate msg _) = do-  updateCache evt-  pure $ map ($ msg) (getEventHandlers @'MessageCreateEvt eh)--handleEvent' eh evt@(MessageUpdate msg) = do-  oldMsg <- getMessage (getID msg)-  updateCache evt-  newMsg <- getMessage (getID msg)-  let rawActions = map ($ msg) (getEventHandlers @'RawMessageUpdateEvt eh)-  let actions = case (oldMsg, newMsg) of-                  (Just oldMsg', Just newMsg') ->-                    map ($ (oldMsg', newMsg')) (getEventHandlers @'MessageUpdateEvt eh)-                  _ -> []-  pure $ rawActions <> actions--handleEvent' eh evt@(MessageDelete MessageDeleteData { id }) = do-  oldMsg <- getMessage id-  updateCache evt-  let rawActions = map ($ id) (getEventHandlers @'RawMessageDeleteEvt eh)-  let actions = case oldMsg of-        Just oldMsg' ->-          map ($ oldMsg') (getEventHandlers @'MessageDeleteEvt eh)-        _ -> []-  pure $ rawActions <> actions--handleEvent' eh evt@(MessageDeleteBulk MessageDeleteBulkData { ids }) = do-  messages <- catMaybes <$> traverse getMessage ids-  updateCache evt-  let rawActions = map ($ ids) (getEventHandlers @'RawMessageDeleteBulkEvt eh)-  let actions = map ($ messages) (getEventHandlers @'MessageDeleteBulkEvt eh)-  pure $ rawActions <> actions--handleEvent' eh evt@(MessageReactionAdd reaction) = do-  updateCache evt-  msg <- getMessage (getID reaction)-  user <- getUser (getID reaction)-  chan <- case reaction ^. #guildID of-    Just _ -> do-      chan <- getGuildChannel (coerceSnowflake $ getID @Channel reaction)-      pure (GuildChannel' <$> chan)-    Nothing -> do-      chan <- getDM (coerceSnowflake $ getID @Channel reaction)-      pure (DMChannel' <$> chan)-  let rawActions = map ($ reaction) (getEventHandlers @'RawMessageReactionAddEvt eh)-  let actions = case (msg, user, chan) of-        (Just msg', Just user', Just chan') ->-          map ($ (msg', user', chan', reaction ^. #emoji)) (getEventHandlers @'MessageReactionAddEvt eh)-        _ -> []-  pure $ rawActions <> actions--handleEvent' eh evt@(MessageReactionRemove reaction) = do-  msg <- getMessage (getID reaction)-  updateCache evt-  user <- getUser (getID reaction)-  chan <- case reaction ^. #guildID of-    Just _ -> do-      chan <- getGuildChannel (coerceSnowflake $ getID @Channel reaction)-      pure (GuildChannel' <$> chan)-    Nothing -> do-      chan <- getDM (coerceSnowflake $ getID @Channel reaction)-      pure (DMChannel' <$> chan)-  let rawActions = map ($ reaction) (getEventHandlers @'RawMessageReactionRemoveEvt eh)-  let actions = case (msg, user, chan) of-        (Just msg', Just user', Just chan') ->-          map ($ (msg', user', chan', reaction ^. #emoji)) (getEventHandlers @'MessageReactionRemoveEvt eh)-        _ -> []-  pure $ rawActions <> actions--handleEvent' eh evt@(MessageReactionRemoveAll MessageReactionRemoveAllData { messageID }) = do-  msg <- getMessage messageID-  updateCache evt-  let rawActions = map ($ messageID) (getEventHandlers @'RawMessageReactionRemoveAllEvt eh)-  let actions = case msg of-        Just msg' ->-          map ($ msg') (getEventHandlers @'MessageReactionRemoveAllEvt eh)-        _ -> []-  pure $ rawActions <> actions--handleEvent' eh evt@(PresenceUpdate PresenceUpdateData { userID, presence = Presence { guildID } }) = do-  Just oldGuild <- getGuild guildID-  Just oldMember <- pure $ oldGuild ^. #members . at (coerceSnowflake userID)-  updateCache evt-  Just newGuild <- getGuild guildID-  Just newMember <- pure $ newGuild ^. #members . at (coerceSnowflake userID)-  let oldUser :: User = upcast oldMember-      newUser :: User = upcast newMember-      userUpdates = if oldUser /= newUser-                    then map ($ (oldUser, newUser)) (getEventHandlers @'UserUpdateEvt eh)-                    else mempty-  pure $ userUpdates <> map ($ (oldMember, newMember)) (getEventHandlers @'GuildMemberUpdateEvt eh)--handleEvent' eh (TypingStart TypingStartData { channelID, guildID, userID, timestamp = UnixTimestamp timestamp }) =-  case guildID of-    Just gid -> do-      Just guild <- getGuild gid-      Just chan <- pure $ GuildChannel' <$> guild ^. #channels . at (coerceSnowflake channelID)-      pure $ map ($ (chan, userID, timestamp)) (getEventHandlers @'TypingStartEvt eh)-    Nothing -> do-      Just chan <- DMChannel' <<$>> getDM (coerceSnowflake channelID)-      pure $ map ($ (chan, userID, timestamp)) (getEventHandlers @'TypingStartEvt eh)--handleEvent' eh evt@(UserUpdate _) = do-  Just oldUser <- getBotUser-  updateCache evt-  Just newUser <- getBotUser-  pure $ map ($ (oldUser, newUser)) (getEventHandlers @'UserUpdateEvt eh)--handleEvent' eh evt@(VoiceStateUpdate newVoiceState@V.VoiceState{guildID=Just guildID}) = do-  oldVoiceState <- ((find ((== V.sessionID newVoiceState) . V.sessionID) . voiceStates) =<<) <$> getGuild guildID-  updateCache evt-  pure $ map ($ (oldVoiceState, newVoiceState)) (getEventHandlers @'VoiceStateUpdateEvt eh)--handleEvent' _ e = fail $ "Unhandled event: " <> show e--updateCache :: P.Members '[CacheEff, P.Fail] r => DispatchData -> P.Sem r ()-updateCache (Ready ReadyData { user, guilds }) = do-  setBotUser user-  for_ (map getID guilds) setUnavailableGuild--updateCache Resumed = pure ()--updateCache (ChannelCreate (DMChannel' chan)) =-  setDM chan--updateCache (ChannelCreate (GuildChannel' chan)) =-  updateGuild (getID chan) (#channels %~ SM.insert chan)--updateCache (ChannelUpdate (DMChannel' chan)) =-  updateDM (getID chan) (update chan)--updateCache (ChannelUpdate (GuildChannel' chan)) =-  updateGuild (getID chan) (#channels . ix (getID chan) %~ update chan)--updateCache (ChannelDelete (DMChannel' chan)) =-  delDM (getID chan)--updateCache (ChannelDelete (GuildChannel' chan)) =-  updateGuild (getID chan) (#channels %~ sans (getID chan))--updateCache (GuildCreate guild) = do-  isNew <- isUnavailableGuild (getID guild)-  when isNew $ delUnavailableGuild (getID guild)-  setGuild guild-  for_ (SM.fromList (guild ^.. #members . traverse . super)) setUser--updateCache (GuildUpdate guild) =-  updateGuild (getID guild) (update guild)--updateCache (GuildDelete UnavailableGuild { id, unavailable }) =-  if unavailable-  then setUnavailableGuild id-  else delGuild id--updateCache (GuildEmojisUpdate GuildEmojisUpdateData { guildID, emojis }) =-  updateGuild guildID (#emojis .~ SM.fromList emojis)--updateCache (GuildMemberAdd member) = do-  setUser (member ^. super)-  updateGuild (getID member) (#members . at (getID member) ?~ member)--updateCache (GuildMemberRemove GuildMemberRemoveData { guildID, user }) =-  updateGuild guildID (#members %~ sans (getID user))--updateCache (GuildMemberUpdate GuildMemberUpdateData { guildID, roles = AesonVector roles, user, nick }) = do-  setUser user-  updateGuild guildID (#members . ix (getID user) %~ (#roles .~ roles) . (#nick .~ nick))--updateCache (GuildMembersChunk GuildMembersChunkData { members }) =-  traverse_ (updateCache . GuildMemberAdd) members--updateCache (GuildRoleCreate GuildRoleData { guildID, role }) =-  updateGuild guildID (#roles %~ SM.insert role)--updateCache (GuildRoleUpdate GuildRoleData { guildID, role }) =-  updateGuild guildID (#roles %~ SM.insert role)--updateCache (GuildRoleDelete GuildRoleDeleteData { guildID, roleID }) =-  updateGuild guildID (#roles %~ sans roleID)--updateCache (MessageCreate !msg !user) = do-  setMessage msg-  for_ user setUser--updateCache (MessageUpdate msg) =-  updateMessage (getID msg) (update msg)--updateCache (MessageDelete MessageDeleteData { id }) = delMessage id--updateCache (MessageDeleteBulk MessageDeleteBulkData { ids }) =-  for_ ids delMessage--updateCache (MessageReactionAdd reaction) = do-  isMe <- (\u -> Just (getID @User reaction) == (getID @User <$> u)) <$> getBotUser-  updateMessage-    (getID reaction)-    ( \m ->-        case m ^. #reactions & filter ((== (reaction ^. #emoji)) . (^. #emoji)) of-          [] -> m & #reactions <>~ [Reaction 1 isMe (reaction ^. #emoji)]-          _ ->-            m & #reactions . traverse . filtered ((== (reaction ^. #emoji)) . (^. #emoji))-              %~ (#count +~ 1) . (#me ||~ isMe)-    )-updateCache (MessageReactionRemove reaction) = do-  isMe <- (\u -> Just (getID @User reaction) == (getID @User <$> u)) <$> getBotUser-  updateMessage-    (getID reaction)-    ( \m ->-        m-          & #reactions . traverse . filtered ((== (reaction ^. #emoji)) . (^. #emoji))-            %~ (#count -~ 1) . (#me &&~ not isMe)-          & #reactions %~ filter (\r -> r ^. #count /= 0)-    )--updateCache (MessageReactionRemoveAll MessageReactionRemoveAllData { messageID }) =-  updateMessage messageID (#reactions .~ mempty)--updateCache (PresenceUpdate PresenceUpdateData { userID, presence }) =-  updateGuild (getID presence) (#presences . at userID ?~ presence)--updateCache (UserUpdate user) = setBotUser user---- we don't handle group channels currently-updateCache (ChannelCreate (GroupChannel' _)) = pure ()-updateCache (ChannelUpdate (GroupChannel' _)) = pure ()-updateCache (ChannelDelete (GroupChannel' _)) = pure ()---- these don't modify state-updateCache (GuildBanAdd _) = pure ()-updateCache (GuildBanRemove _) = pure ()-updateCache (GuildIntegrationsUpdate _) = pure ()-updateCache (TypingStart _) = pure ()-updateCache (ChannelPinsUpdate _) = pure ()-updateCache (WebhooksUpdate _) = pure ()-updateCache (InviteCreate _) = pure ()-updateCache (InviteDelete _) = pure ()--updateCache (VoiceStateUpdate voiceState@V.VoiceState{guildID=Just guildID}) =-  updateGuild guildID (#voiceStates %~ updateVoiceStates)-  where-    updateVoiceStates [] = [voiceState]-    updateVoiceStates (x:xs)-        | V.sessionID x == V.sessionID voiceState = voiceState : xs-        | otherwise = x : updateVoiceStates xs--  -- we don't handle voice server update and direct voice connections currently-updateCache (VoiceStateUpdate V.VoiceState{guildID=Nothing}) = pure ()-updateCache (VoiceServerUpdate _) = pure ()+    react,+    runBotIO,+    runBotIO',+    stopBot,+    sendPresence,+    events,+    fire,+    waitUntil,+    waitUntilM,+    CalamityEvent (Dispatch, ShutDown),+    customEvt,+) where++import Calamity.Cache.Eff+import Calamity.Client.ShardManager+import Calamity.Client.Types+import Calamity.Gateway.DispatchEvents+import Calamity.Gateway.Intents+import Calamity.Gateway.Types+import Calamity.HTTP.Internal.Ratelimit+import Calamity.Internal.ConstructorName+import Calamity.Internal.RunIntoIO+import qualified Calamity.Internal.SnowflakeMap as SM+import Calamity.Internal.UnixTimestamp+import Calamity.Internal.Updateable+import Calamity.Internal.Utils+import Calamity.Metrics.Eff+import Calamity.Types.LogEff+import Calamity.Types.Model.Channel+import Calamity.Types.Model.Guild+import Calamity.Types.Model.Presence (Presence (..))+import Calamity.Types.Model.User+import qualified Calamity.Types.Model.Voice as V+import Calamity.Types.Snowflake+import Calamity.Types.Token+import Control.Concurrent.Chan.Unagi+import Control.Concurrent.MVar+import Control.Concurrent.STM+import Control.Exception (SomeException)+import Control.Lens hiding ((<.>))+import Control.Monad+import Data.Default.Class+import Data.Dynamic+import Data.Foldable+import Data.Generics.Product.Subtype+import Data.IORef+import Data.Maybe+import Data.Proxy+import qualified Data.Text as S+import Data.Time.Clock.POSIX+import qualified Df1+import qualified Di.Core as DC+import qualified DiPolysemy as Di+import qualified Polysemy as P+import qualified Polysemy.Async as P+import qualified Polysemy.AtomicState as P+import qualified Polysemy.Error as P+import qualified Polysemy.Fail as P+import qualified Polysemy.Reader as P+import qualified Polysemy.Resource as P+import PyF+import TextShow (TextShow (showt))++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+    end <- P.embed getPOSIXTime+    let duration = fromRational . toRational $ end - start+    pure (duration, res)++newClient :: Token -> Maybe (DC.Di Df1.Level Df1.Path Df1.Message) -> IO Client+newClient token initialDi = do+    shards' <- newTVarIO []+    numShards' <- newEmptyMVar+    rlState' <- newRateLimitState+    (inc, outc) <- newChan+    ehidCounter <- newIORef 0++    pure $+        Client+            shards'+            numShards'+            token+            rlState'+            inc+            outc+            ehidCounter+            initialDi++-- | Create a bot, run your setup action, and then loop until the bot closes.+runBotIO ::+    forall r a.+    (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff, LogEff] r, Typeable (SetupEff r)) =>+    Token ->+    -- | The intents the bot should use+    Intents ->+    P.Sem (SetupEff r) a ->+    P.Sem r (Maybe StartupError)+runBotIO token intents = runBotIO' token intents Nothing++resetDi :: BotC r => P.Sem r a -> P.Sem r a+resetDi m = do+    initialDi <- P.asks (^. #initialDi)+    Di.local (flip fromMaybe initialDi) m++{- | Create a bot, run your setup action, and then loop until the bot closes.++ This version allows you to specify the initial status, and intents.+-}+runBotIO' ::+    forall r a.+    (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff, LogEff] r, Typeable (SetupEff r)) =>+    Token ->+    -- | The intents the bot should use+    Intents ->+    -- | The initial status to send to the gateway+    Maybe StatusUpdateData ->+    P.Sem (SetupEff r) a ->+    P.Sem r (Maybe StartupError)+runBotIO' token intents status setup = do+    initialDi <- Di.fetch+    client <- P.embed $ newClient token initialDi+    handlers <- P.embed $ newTVarIO def+    P.asyncToIOFinal . P.runAtomicStateTVar handlers . P.runReader client . Di.push "calamity" $ do+        void $ Di.push "calamity-setup" setup+        r <- shardBot status intents+        case r of+            Left e -> pure (Just e)+            Right _ -> do+                Di.push "calamity-loop" clientLoop+                Di.push "calamity-stop" finishUp+                pure Nothing++{- | 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+ parameters the event handlers they receive.++ You'll probably want @TypeApplications@ and need @DataKinds@ enabled to+ specify the type of @s@.++ ==== Examples++ Reacting to every message:++ @+ 'react' @\''MessageCreateEvt' '$' \msg -> 'print' '$' "Got message: " '<>' 'show' msg+ @++ Reacting to a custom event:++ @+ data MyCustomEvt = MyCustomEvt 'Data.Text.Text' 'Message'++ 'react' @(\''CustomEvt' MyCustomEvt) $ \\(MyCustomEvt s m) ->+    'void' $ 'Calamity.Types.Tellable.tell' @'Data.Text.Text' m ("Somebody told me to tell you about: " '<>' s)+ @++ ==== Notes++ This function is pretty bad for giving nasty type errors,+ since if something doesn't match then 'EHType' might not get substituted,+ which will result in errors about parameter counts mismatching.+-}+react ::+    forall (s :: EventType) r.+    (BotC r, ReactConstraints s) =>+    (EHType s -> (P.Sem r) ()) ->+    P.Sem r (P.Sem r ())+react handler = do+    handler' <- bindSemToIO handler+    ehidC <- P.asks (^. #ehidCounter)+    id' <- P.embed $ atomicModifyIORef ehidC (\i -> (i + 1, i))+    let handlers = makeEventHandlers (Proxy @s) id' (const () <.> handler')+    P.atomicModify (handlers <>)+    pure $ removeHandler @s id'++removeHandler :: forall (s :: EventType) r. (BotC r, RemoveEventHandler s) => Integer -> P.Sem r ()+removeHandler id' = P.atomicModify (removeEventHandler (Proxy @s) id')++{- | Fire an event that the bot will then handle.++ ==== Examples++ Firing an event named \"my-event\":++ @+ 'fire' '$' 'customEvt' @"my-event" ("aha" :: 'Data.Text.Text', msg)+ @+-}+fire :: BotC r => CalamityEvent -> P.Sem r ()+fire e = do+    inc <- P.asks (^. #eventsIn)+    P.embed $ writeChan inc e++{- | Build a Custom CalamityEvent++ The type of @a@ must match up with the event handler you want to receive it.++ ==== Examples++ @+ 'customEvt' (MyCustomEvent "lol")+ @+-}+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 = do+    inc <- P.asks (^. #eventsIn)+    P.embed $ dupChan inc++{- | Wait until an event satisfying a condition happens, then returns it's+ parameters.++ The check function for this command is pure unlike 'waitUntilM'++ This is what it would look like with @s ~ \''MessageCreateEvt'@:++ @+ 'waitUntil' :: ('Message' -> 'Bool') -> 'P.Sem' r 'Message'+ @++ And for @s ~ \''MessageUpdateEvt'@:++ @+ 'waitUntil' :: (('Message', 'Message') -> 'Bool') -> 'P.Sem' r ('Message', 'Message')+ @++ ==== Examples++ Waiting for a message containing the text \"hi\":++ @+ f = do msg \<\- 'waitUntil' @\''MessageCreateEvt' (\\m -> 'Data.Text.Lazy.isInfixOf' "hi" $ m ^. #content)+        print $ msg ^. #content+ @+-}+waitUntil ::+    forall (s :: EventType) r.+    (BotC r, ReactConstraints s) =>+    (EHType s -> Bool) ->+    P.Sem r (EHType s)+waitUntil f = P.resourceToIOFinal $ do+    result <- P.embed newEmptyMVar+    P.bracket+        (P.raise $ react @s (checker result))+        P.raise+        (const . P.embed $ takeMVar result)+  where+    checker :: MVar (EHType s) -> EHType s -> P.Sem r ()+    checker result args = do+        when (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.+    (BotC r, ReactConstraints s) =>+    (EHType s -> P.Sem r Bool) ->+    P.Sem r (EHType s)+waitUntilM f = P.resourceToIOFinal $ do+    result <- P.embed newEmptyMVar+    P.bracket+        (P.raise $ react @s (checker result))+        P.raise+        (const . P.embed $ takeMVar result)+  where+    checker :: MVar (EHType s) -> EHType s -> P.Sem r ()+    checker result args = do+        res <- f args+        when res $ do+            P.embed $ putMVar result args++-- | Set the bot's presence on all shards.+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 = do+    debug "stopping bot"+    inc <- P.asks (^. #eventsIn)+    P.embed $ writeChan inc ShutDown++finishUp :: BotC r => P.Sem r ()+finishUp = do+    debug "finishing up"+    shards <- P.asks (^. #shards) >>= P.embed . readTVarIO+    for_ shards $ \(inc, _) ->+        P.embed $ writeChan inc ShutDownShard+    for_ shards $ \(_, shardThread) -> P.await shardThread+    debug "bot has stopped"++{- | main loop of the client, handles fetching the next event, processing the+ event and invoking it's handler functions+-}+clientLoop :: BotC r => P.Sem r ()+clientLoop = do+    outc <- P.asks (^. #eventsOut)+    whileMFinalIO $ do+        !evt' <- P.embed $ readChan outc+        case evt' of+            Dispatch !sid !evt -> handleEvent sid evt >> pure True+            Custom d -> handleCustomEvent d >> pure True+            ShutDown -> pure False+    debug "leaving client loop"++handleCustomEvent :: forall a r. (Typeable a, BotC r) => a -> P.Sem r ()+handleCustomEvent d = do+    eventHandlers <- P.atomicGet++    let handlers = getCustomEventHandlers @a eventHandlers++    for_ handlers (\h -> P.async . P.embed $ h d)++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 [fmt|got exception: {e:s}|]++handleEvent :: BotC r => Int -> DispatchData -> P.Sem r ()+handleEvent shardID data' = do+    debug "handling an event"+    eventHandlers <- P.atomicGet+    actions <- P.runFail $ do+        evtCounter <- registerCounter "events_received" [("type", S.pack $ ctorName data'), ("shard", showt shardID)]+        void $ addCounter 1 evtCounter+        cacheUpdateHisto <- registerHistogram "cache_update" mempty [10, 20 .. 100]+        (time, res) <- timeA $ resetDi $ handleEvent' eventHandlers data'+        void $ observeHistogram time cacheUpdateHisto+        pure res++    eventHandleHisto <- registerHistogram "event_handle" mempty [10, 20 .. 100]++    case actions of+        Right actions -> for_ actions $ \action -> P.async $ do+            (time, _) <- timeA . catchAllLogging $ P.embed action+            void $ observeHistogram time eventHandleHisto+        -- pattern match failures are usually stuff like events for uncached guilds, etc+        Left err -> debug [fmt|Failed handling actions for event: {err:s}|]++handleEvent' ::+    BotC r =>+    EventHandlers ->+    DispatchData ->+    P.Sem (P.Fail ': r) [IO ()]+handleEvent' eh evt@(Ready rd@ReadyData{}) = do+    updateCache evt+    pure $ map ($ rd) (getEventHandlers @ 'ReadyEvt eh)+handleEvent' _ Resumed = pure []+handleEvent' eh evt@(ChannelCreate (DMChannel' chan)) = do+    updateCache evt+    Just newChan <- DMChannel' <<$>> getDM (getID chan)+    pure $ map ($ newChan) (getEventHandlers @ 'ChannelCreateEvt eh)+handleEvent' eh evt@(ChannelCreate (GuildChannel' chan)) = do+    updateCache evt+    Just guild <- getGuild (getID chan)+    Just newChan <- pure $ GuildChannel' <$> guild ^. #channels . at (getID chan)+    pure $ map ($ newChan) (getEventHandlers @ 'ChannelCreateEvt eh)+handleEvent' eh evt@(ChannelUpdate (DMChannel' chan)) = do+    Just oldChan <- DMChannel' <<$>> getDM (getID chan)+    updateCache evt+    Just newChan <- DMChannel' <<$>> getDM (getID chan)+    pure $ map ($ (oldChan, newChan)) (getEventHandlers @ 'ChannelUpdateEvt eh)+handleEvent' eh evt@(ChannelUpdate (GuildChannel' chan)) = do+    Just oldGuild <- getGuild (getID chan)+    Just oldChan <- pure $ GuildChannel' <$> oldGuild ^. #channels . at (getID chan)+    updateCache evt+    Just newGuild <- getGuild (getID chan)+    Just newChan <- pure $ GuildChannel' <$> newGuild ^. #channels . at (getID chan)+    pure $ map ($ (oldChan, newChan)) (getEventHandlers @ 'ChannelUpdateEvt eh)+handleEvent' eh evt@(ChannelDelete (GuildChannel' chan)) = do+    Just oldGuild <- getGuild (getID chan)+    Just oldChan <- pure $ GuildChannel' <$> oldGuild ^. #channels . at (getID chan)+    updateCache evt+    pure $ map ($ oldChan) (getEventHandlers @ 'ChannelDeleteEvt eh)+handleEvent' eh evt@(ChannelDelete (DMChannel' chan)) = do+    Just oldChan <- DMChannel' <<$>> getDM (getID chan)+    updateCache evt+    pure $ map ($ oldChan) (getEventHandlers @ 'ChannelDeleteEvt eh)++-- handleEvent' eh evt@(ChannelPinsUpdate ChannelPinsUpdateData { channelID, lastPinTimestamp }) = do+--   chan <- (GuildChannel' <$> os ^? #channels . at (coerceSnowflake channelID) . _Just)+--     <|> (DMChannel' <$> os ^? #dms . at (coerceSnowflake channelID) . _Just)+--   pure $ map (\f -> f chan lastPinTimestamp) (getEventHandlers @"channelpinsupdate" eh)++handleEvent' eh evt@(GuildCreate guild) = do+    isNew <- not <$> isUnavailableGuild (getID guild)+    updateCache evt+    Just guild <- getGuild (getID guild)+    pure $+        map+            ($ (guild, (if isNew then GuildCreateNew else GuildCreateAvailable)))+            (getEventHandlers @ 'GuildCreateEvt eh)+handleEvent' eh evt@(GuildUpdate guild) = do+    Just oldGuild <- getGuild (getID guild)+    updateCache evt+    Just newGuild <- getGuild (getID guild)+    pure $ map ($ (oldGuild, newGuild)) (getEventHandlers @ 'GuildUpdateEvt eh)++-- NOTE: Guild will be deleted in the new cache if unavailable was false+handleEvent' eh evt@(GuildDelete UnavailableGuild{id, unavailable}) = do+    Just oldGuild <- getGuild id+    updateCache evt+    pure $+        map+            ($ (oldGuild, (if unavailable then GuildDeleteUnavailable else GuildDeleteRemoved)))+            (getEventHandlers @ 'GuildDeleteEvt eh)+handleEvent' eh evt@(GuildBanAdd BanData{guildID, user}) = do+    Just guild <- getGuild guildID+    updateCache evt+    pure $ map ($ (guild, user)) (getEventHandlers @ 'GuildBanAddEvt eh)+handleEvent' eh evt@(GuildBanRemove BanData{guildID, user}) = do+    Just guild <- getGuild guildID+    updateCache evt+    pure $ map ($ (guild, user)) (getEventHandlers @ 'GuildBanRemoveEvt eh)++-- NOTE: we fire this event using the guild data with old emojis+handleEvent' eh evt@(GuildEmojisUpdate GuildEmojisUpdateData{guildID, emojis}) = do+    Just guild <- getGuild guildID+    updateCache evt+    pure $ map ($ (guild, emojis)) (getEventHandlers @ 'GuildEmojisUpdateEvt eh)+handleEvent' eh evt@(GuildIntegrationsUpdate GuildIntegrationsUpdateData{guildID}) = do+    updateCache evt+    Just guild <- getGuild guildID+    pure $ map ($ guild) (getEventHandlers @ 'GuildIntegrationsUpdateEvt eh)+handleEvent' eh evt@(GuildMemberAdd member) = do+    updateCache evt+    Just guild <- getGuild (getID member)+    Just member <- pure $ guild ^. #members . at (getID member)+    pure $ map ($ member) (getEventHandlers @ 'GuildMemberAddEvt eh)+handleEvent' eh evt@(GuildMemberRemove GuildMemberRemoveData{user, guildID}) = do+    Just guild <- getGuild guildID+    Just member <- pure $ guild ^. #members . at (getID user)+    updateCache evt+    pure $ map ($ member) (getEventHandlers @ 'GuildMemberRemoveEvt eh)+handleEvent' eh evt@(GuildMemberUpdate GuildMemberUpdateData{user, guildID}) = do+    Just oldGuild <- getGuild guildID+    Just oldMember <- pure $ oldGuild ^. #members . at (getID user)+    updateCache evt+    Just newGuild <- getGuild guildID+    Just newMember <- pure $ newGuild ^. #members . at (getID user)+    pure $ map ($ (oldMember, newMember)) (getEventHandlers @ 'GuildMemberUpdateEvt eh)+handleEvent' eh evt@(GuildMembersChunk GuildMembersChunkData{members, guildID}) = do+    updateCache evt+    Just guild <- getGuild guildID+    let memberIDs = map (getID @Member) members+    let members' = catMaybes $ map (\mid -> guild ^. #members . at mid) memberIDs+    pure $ map ($ (guild, members')) (getEventHandlers @ 'GuildMembersChunkEvt eh)+handleEvent' eh evt@(GuildRoleCreate GuildRoleData{guildID, role}) = do+    updateCache evt+    Just guild <- getGuild guildID+    Just role' <- pure $ guild ^. #roles . at (getID role)+    pure $ map ($ (guild, role')) (getEventHandlers @ 'GuildRoleCreateEvt eh)+handleEvent' eh evt@(GuildRoleUpdate GuildRoleData{guildID, role}) = do+    Just oldGuild <- getGuild guildID+    Just oldRole <- pure $ oldGuild ^. #roles . at (getID role)+    updateCache evt+    Just newGuild <- getGuild guildID+    Just newRole <- pure $ newGuild ^. #roles . at (getID role)+    pure $ map ($ (newGuild, oldRole, newRole)) (getEventHandlers @ 'GuildRoleUpdateEvt eh)+handleEvent' eh evt@(GuildRoleDelete GuildRoleDeleteData{guildID, roleID}) = do+    Just guild <- getGuild guildID+    Just role <- pure $ guild ^. #roles . at roleID+    updateCache evt+    pure $ map ($ (guild, role)) (getEventHandlers @ 'GuildRoleDeleteEvt eh)+handleEvent' eh (InviteCreate d) = do+    pure $ map ($ d) (getEventHandlers @ 'InviteCreateEvt eh)+handleEvent' eh (InviteDelete d) = do+    pure $ map ($ d) (getEventHandlers @ 'InviteDeleteEvt eh)+handleEvent' eh evt@(MessageCreate msg _) = do+    updateCache evt+    pure $ map ($ msg) (getEventHandlers @ 'MessageCreateEvt eh)+handleEvent' eh evt@(MessageUpdate msg) = do+    oldMsg <- getMessage (getID msg)+    updateCache evt+    newMsg <- getMessage (getID msg)+    let rawActions = map ($ msg) (getEventHandlers @ 'RawMessageUpdateEvt eh)+    let actions = case (oldMsg, newMsg) of+            (Just oldMsg', Just newMsg') ->+                map ($ (oldMsg', newMsg')) (getEventHandlers @ 'MessageUpdateEvt eh)+            _ -> []+    pure $ rawActions <> actions+handleEvent' eh evt@(MessageDelete MessageDeleteData{id}) = do+    oldMsg <- getMessage id+    updateCache evt+    let rawActions = map ($ id) (getEventHandlers @ 'RawMessageDeleteEvt eh)+    let actions = case oldMsg of+            Just oldMsg' ->+                map ($ oldMsg') (getEventHandlers @ 'MessageDeleteEvt eh)+            _ -> []+    pure $ rawActions <> actions+handleEvent' eh evt@(MessageDeleteBulk MessageDeleteBulkData{ids}) = do+    messages <- catMaybes <$> traverse getMessage ids+    updateCache evt+    let rawActions = map ($ ids) (getEventHandlers @ 'RawMessageDeleteBulkEvt eh)+    let actions = map ($ messages) (getEventHandlers @ 'MessageDeleteBulkEvt eh)+    pure $ rawActions <> actions+handleEvent' eh evt@(MessageReactionAdd reaction) = do+    updateCache evt+    msg <- getMessage (getID reaction)+    user <- getUser (getID reaction)+    chan <- case reaction ^. #guildID of+        Just _ -> do+            chan <- getGuildChannel (coerceSnowflake $ getID @Channel reaction)+            pure (GuildChannel' <$> chan)+        Nothing -> do+            chan <- getDM (coerceSnowflake $ getID @Channel reaction)+            pure (DMChannel' <$> chan)+    let rawActions = map ($ reaction) (getEventHandlers @ 'RawMessageReactionAddEvt eh)+    let actions = case (msg, user, chan) of+            (Just msg', Just user', Just chan') ->+                map ($ (msg', user', chan', reaction ^. #emoji)) (getEventHandlers @ 'MessageReactionAddEvt eh)+            _ -> []+    pure $ rawActions <> actions+handleEvent' eh evt@(MessageReactionRemove reaction) = do+    msg <- getMessage (getID reaction)+    updateCache evt+    user <- getUser (getID reaction)+    chan <- case reaction ^. #guildID of+        Just _ -> do+            chan <- getGuildChannel (coerceSnowflake $ getID @Channel reaction)+            pure (GuildChannel' <$> chan)+        Nothing -> do+            chan <- getDM (coerceSnowflake $ getID @Channel reaction)+            pure (DMChannel' <$> chan)+    let rawActions = map ($ reaction) (getEventHandlers @ 'RawMessageReactionRemoveEvt eh)+    let actions = case (msg, user, chan) of+            (Just msg', Just user', Just chan') ->+                map ($ (msg', user', chan', reaction ^. #emoji)) (getEventHandlers @ 'MessageReactionRemoveEvt eh)+            _ -> []+    pure $ rawActions <> actions+handleEvent' eh evt@(MessageReactionRemoveAll MessageReactionRemoveAllData{messageID}) = do+    msg <- getMessage messageID+    updateCache evt+    let rawActions = map ($ messageID) (getEventHandlers @ 'RawMessageReactionRemoveAllEvt eh)+    let actions = case msg of+            Just msg' ->+                map ($ msg') (getEventHandlers @ 'MessageReactionRemoveAllEvt eh)+            _ -> []+    pure $ rawActions <> actions+handleEvent' eh evt@(PresenceUpdate PresenceUpdateData{userID, presence = Presence{guildID}}) = do+    Just oldGuild <- getGuild guildID+    Just oldMember <- pure $ oldGuild ^. #members . at (coerceSnowflake userID)+    updateCache evt+    Just newGuild <- getGuild guildID+    Just newMember <- pure $ newGuild ^. #members . at (coerceSnowflake userID)+    let oldUser :: User = upcast oldMember+        newUser :: User = upcast newMember+        userUpdates =+            if oldUser /= newUser+                then map ($ (oldUser, newUser)) (getEventHandlers @ 'UserUpdateEvt eh)+                else mempty+    pure $ userUpdates <> map ($ (oldMember, newMember)) (getEventHandlers @ 'GuildMemberUpdateEvt eh)+handleEvent' eh (TypingStart TypingStartData{channelID, guildID, userID, timestamp = UnixTimestamp timestamp}) =+    case guildID of+        Just gid -> do+            Just guild <- getGuild gid+            Just chan <- pure $ GuildChannel' <$> guild ^. #channels . at (coerceSnowflake channelID)+            pure $ map ($ (chan, userID, timestamp)) (getEventHandlers @ 'TypingStartEvt eh)+        Nothing -> do+            Just chan <- DMChannel' <<$>> getDM (coerceSnowflake channelID)+            pure $ map ($ (chan, userID, timestamp)) (getEventHandlers @ 'TypingStartEvt eh)+handleEvent' eh evt@(UserUpdate _) = do+    Just oldUser <- getBotUser+    updateCache evt+    Just newUser <- getBotUser+    pure $ map ($ (oldUser, newUser)) (getEventHandlers @ 'UserUpdateEvt eh)+handleEvent' eh evt@(VoiceStateUpdate newVoiceState@V.VoiceState{guildID = Just guildID}) = do+    oldVoiceState <- ((find ((== V.sessionID newVoiceState) . V.sessionID) . voiceStates) =<<) <$> getGuild guildID+    updateCache evt+    pure $ map ($ (oldVoiceState, newVoiceState)) (getEventHandlers @ 'VoiceStateUpdateEvt eh)+handleEvent' eh evt@(InteractionCreate interaction) = do+    updateCache evt+    pure $ map ($ interaction) (getEventHandlers @ 'InteractionEvt eh)+handleEvent' _ e = fail $ "Unhandled event: " <> show e++updateCache :: P.Members '[CacheEff, P.Fail] r => DispatchData -> P.Sem r ()+updateCache (Ready ReadyData{user, guilds}) = do+    setBotUser user+    for_ (map getID guilds) setUnavailableGuild+updateCache Resumed = pure ()+updateCache (ChannelCreate (DMChannel' chan)) =+    setDM chan+updateCache (ChannelCreate (GuildChannel' chan)) =+    updateGuild (getID chan) (#channels %~ SM.insert chan)+updateCache (ChannelUpdate (DMChannel' chan)) =+    updateDM (getID chan) (update chan)+updateCache (ChannelUpdate (GuildChannel' chan)) =+    updateGuild (getID chan) (#channels . ix (getID chan) %~ update chan)+updateCache (ChannelDelete (DMChannel' chan)) =+    delDM (getID chan)+updateCache (ChannelDelete (GuildChannel' chan)) =+    updateGuild (getID chan) (#channels %~ sans (getID chan))+updateCache (GuildCreate guild) = do+    isNew <- isUnavailableGuild (getID guild)+    when isNew $ delUnavailableGuild (getID guild)+    setGuild guild+    for_ (SM.fromList (guild ^.. #members . traverse . super)) setUser+updateCache (GuildUpdate guild) =+    updateGuild (getID guild) (update guild)+updateCache (GuildDelete UnavailableGuild{id, unavailable}) =+    if unavailable+        then setUnavailableGuild id+        else delGuild id+updateCache (GuildEmojisUpdate GuildEmojisUpdateData{guildID, emojis}) =+    updateGuild guildID (#emojis .~ SM.fromList emojis)+updateCache (GuildMemberAdd member) = do+    setUser (member ^. super)+    updateGuild (getID member) (#members . at (getID member) ?~ member)+updateCache (GuildMemberRemove GuildMemberRemoveData{guildID, user}) =+    updateGuild guildID (#members %~ sans (getID user))+updateCache (GuildMemberUpdate GuildMemberUpdateData{guildID, roles = AesonVector roles, user, nick}) = do+    setUser user+    updateGuild guildID (#members . ix (getID user) %~ (#roles .~ roles) . (#nick .~ nick))+updateCache (GuildMembersChunk GuildMembersChunkData{members}) =+    traverse_ (updateCache . GuildMemberAdd) members+updateCache (GuildRoleCreate GuildRoleData{guildID, role}) =+    updateGuild guildID (#roles %~ SM.insert role)+updateCache (GuildRoleUpdate GuildRoleData{guildID, role}) =+    updateGuild guildID (#roles %~ SM.insert role)+updateCache (GuildRoleDelete GuildRoleDeleteData{guildID, roleID}) =+    updateGuild guildID (#roles %~ sans roleID)+updateCache (MessageCreate !msg !user) = do+    setMessage msg+    for_ user setUser+updateCache (MessageUpdate msg) =+    updateMessage (getID msg) (update msg)+updateCache (MessageDelete MessageDeleteData{id}) = delMessage id+updateCache (MessageDeleteBulk MessageDeleteBulkData{ids}) =+    for_ ids delMessage+updateCache (MessageReactionAdd reaction) = do+    isMe <- (\u -> Just (getID @User reaction) == (getID @User <$> u)) <$> getBotUser+    updateMessage+        (getID reaction)+        ( \m ->+            case m ^. #reactions & filter ((== (reaction ^. #emoji)) . (^. #emoji)) of+                [] -> m & #reactions <>~ [Reaction 1 isMe (reaction ^. #emoji)]+                _ ->+                    m & #reactions . traverse . filtered ((== (reaction ^. #emoji)) . (^. #emoji))+                        %~ (#count +~ 1) . (#me ||~ isMe)+        )+updateCache (MessageReactionRemove reaction) = do+    isMe <- (\u -> Just (getID @User reaction) == (getID @User <$> u)) <$> getBotUser+    updateMessage+        (getID reaction)+        ( \m ->+            m+                & #reactions . traverse . filtered ((== (reaction ^. #emoji)) . (^. #emoji))+                    %~ (#count -~ 1) . (#me &&~ not isMe)+                & #reactions %~ filter (\r -> r ^. #count /= 0)+        )+updateCache (MessageReactionRemoveAll MessageReactionRemoveAllData{messageID}) =+    updateMessage messageID (#reactions .~ mempty)+updateCache (PresenceUpdate PresenceUpdateData{userID, presence}) =+    updateGuild (getID presence) (#presences . at userID ?~ presence)+updateCache (UserUpdate user) = setBotUser user+-- we don't handle group channels currently+updateCache (ChannelCreate (GroupChannel' _)) = pure ()+updateCache (ChannelUpdate (GroupChannel' _)) = pure ()+updateCache (ChannelDelete (GroupChannel' _)) = pure ()+-- these don't modify state+updateCache (GuildBanAdd _) = pure ()+updateCache (GuildBanRemove _) = pure ()+updateCache (GuildIntegrationsUpdate _) = pure ()+updateCache (TypingStart _) = pure ()+updateCache (ChannelPinsUpdate _) = pure ()+updateCache (WebhooksUpdate _) = pure ()+updateCache (InviteCreate _) = pure ()+updateCache (InviteDelete _) = pure ()+updateCache (VoiceStateUpdate voiceState@V.VoiceState{guildID = Just guildID}) =+    updateGuild guildID (#voiceStates %~ updateVoiceStates)+  where+    updateVoiceStates [] = [voiceState]+    updateVoiceStates (x : xs)+        | V.sessionID x == V.sessionID voiceState = voiceState : xs+        | otherwise = x : updateVoiceStates xs++-- we don't handle voice server update and direct voice connections currently+updateCache (VoiceStateUpdate V.VoiceState{guildID = Nothing}) = pure ()+updateCache (VoiceServerUpdate _) = pure ()+-- we don't update the cache from interactions+-- TODO: should we?+updateCache (InteractionCreate _) = pure ()

@@ -29,12 +29,10 @@ import Calamity.Types.Model.Voice import Calamity.Types.Snowflake import Calamity.Types.Token- import Control.Concurrent.Async import Control.Concurrent.Chan.Unagi import Control.Concurrent.MVar import Control.Concurrent.STM.TVar- import Data.Default.Class import Data.Dynamic import Data.IORef@@ -43,21 +41,19 @@ import Data.TypeRepMap (TypeRepMap, WrapTypeable (..)) import qualified Data.TypeRepMap as TM import Data.Typeable- import GHC.Exts (fromList) import GHC.Generics- import qualified Polysemy as P import qualified Polysemy.Async as P import qualified Polysemy.AtomicState as P import qualified Polysemy.Reader as P- import qualified Df1 import qualified Di.Core as DC import TextShow import qualified TextShow.Generic as TSG import Data.Kind (Type) import Data.Void (Void)+import Calamity.Types.Model.Interaction (Interaction)  data Client = Client   { shards :: TVar [(InChan ControlMessage, Async (Maybe ()))]@@ -167,6 +163,8 @@   | UserUpdateEvt   | -- | Sent when someone joins/leaves/moves voice channels     VoiceStateUpdateEvt+  | -- | Fired when the bot receives an interaction+    InteractionEvt   | -- | A custom event, @a@ is the data sent to the handler and should probably     -- be a newtype to disambiguate events     forall (a :: Type). CustomEvt a@@ -228,6 +226,7 @@   EHType 'TypingStartEvt = (Channel, Snowflake User, UTCTime)   EHType 'UserUpdateEvt = (User, User)   EHType 'VoiceStateUpdateEvt = (Maybe VoiceState, VoiceState)+  EHType 'InteractionEvt = Interaction   EHType ( 'CustomEvt a) = a  type StoredEHType t = EHType t -> IO ()@@ -290,6 +289,7 @@         , WrapTypeable $ EH @'MessageReactionRemoveAllEvt []         , WrapTypeable $ EH @'TypingStartEvt []         , WrapTypeable $ EH @'UserUpdateEvt []+        , WrapTypeable $ EH @'InteractionEvt []         , WrapTypeable $ EH @('CustomEvt Void) TM.empty         ] 

@@ -59,6 +59,9 @@   }   deriving (Show, Generic)   deriving (TextShow) via TSG.FromGeneric FullContext+  deriving (HasID Channel) via HasIDField "channel" FullContext+  deriving (HasID Message) via HasIDField "message" FullContext+  deriving (HasID User) via HasIDField "user" FullContext  instance CC.CommandContext IO FullContext () where   ctxPrefix = (^. #prefix)@@ -112,6 +115,9 @@   }   deriving (Show, Generic)   deriving (TextShow) via TSG.FromGeneric LightContext+  deriving (HasID Channel) via HasIDField "channelID" LightContext+  deriving (HasID Message) via HasIDField "message" LightContext+  deriving (HasID User) via HasIDField "userID" LightContext  instance CC.CommandContext IO LightContext () where   ctxPrefix = (^. #prefix)

@@ -4,6 +4,7 @@ import Calamity.Internal.AesonThings import Calamity.Internal.ConstructorName import Calamity.Internal.UnixTimestamp+import Calamity.Internal.Utils import Calamity.Types.Model.Channel import Calamity.Types.Model.Channel.UpdatedMessage import Calamity.Types.Model.Guild.Ban@@ -12,6 +13,7 @@ import Calamity.Types.Model.Guild.Member import Calamity.Types.Model.Guild.Role import Calamity.Types.Model.Guild.UnavailableGuild+import Calamity.Types.Model.Interaction import Calamity.Types.Model.Presence.Presence import Calamity.Types.Model.User import Calamity.Types.Model.Voice@@ -22,221 +24,221 @@ import Data.Time import Data.Typeable (Typeable) import GHC.Generics-import Calamity.Internal.Utils  data CalamityEvent-  = Dispatch-      Int-      -- ^ The shard that pushed this event-      DispatchData-      -- ^ The attached data-  | -- | The data sent to the custom event-    forall (a :: Type). Typeable a => Custom a-  | ShutDown+    = Dispatch+        Int+        -- ^ The shard that pushed this event+        DispatchData+        -- ^ The attached data+    | -- | The data sent to the custom event+      forall (a :: Type). Typeable a => Custom a+    | ShutDown  data DispatchData-  = Ready !ReadyData-  | Resumed-  | ChannelCreate !Channel-  | ChannelUpdate !Channel-  | ChannelDelete !Channel-  | ChannelPinsUpdate !ChannelPinsUpdateData-  | GuildCreate !Guild-  | GuildUpdate !UpdatedGuild-  | GuildDelete !UnavailableGuild-  | GuildBanAdd !BanData-  | GuildBanRemove !BanData-  | GuildEmojisUpdate !GuildEmojisUpdateData-  | GuildIntegrationsUpdate !GuildIntegrationsUpdateData-  | GuildMemberAdd !Member-  | GuildMemberRemove !GuildMemberRemoveData-  | GuildMemberUpdate !GuildMemberUpdateData-  | GuildMembersChunk !GuildMembersChunkData-  | GuildRoleCreate !GuildRoleData-  | GuildRoleUpdate !GuildRoleData-  | GuildRoleDelete !GuildRoleDeleteData-  | InviteCreate !InviteCreateData-  | InviteDelete !InviteDeleteData-  | MessageCreate !Message !(Maybe User)-  | MessageUpdate !UpdatedMessage-  | MessageDelete !MessageDeleteData-  | MessageDeleteBulk !MessageDeleteBulkData-  | MessageReactionAdd !ReactionEvtData-  | MessageReactionRemove !ReactionEvtData-  | MessageReactionRemoveAll !MessageReactionRemoveAllData-  | PresenceUpdate !PresenceUpdateData-  | TypingStart !TypingStartData-  | UserUpdate !User-  | VoiceStateUpdate !VoiceState-  | VoiceServerUpdate !VoiceServerUpdateData-  | WebhooksUpdate !WebhooksUpdateData-  deriving (Show, Generic, CtorName)+    = Ready !ReadyData+    | Resumed+    | ChannelCreate !Channel+    | ChannelUpdate !Channel+    | ChannelDelete !Channel+    | ChannelPinsUpdate !ChannelPinsUpdateData+    | GuildCreate !Guild+    | GuildUpdate !UpdatedGuild+    | GuildDelete !UnavailableGuild+    | GuildBanAdd !BanData+    | GuildBanRemove !BanData+    | GuildEmojisUpdate !GuildEmojisUpdateData+    | GuildIntegrationsUpdate !GuildIntegrationsUpdateData+    | GuildMemberAdd !Member+    | GuildMemberRemove !GuildMemberRemoveData+    | GuildMemberUpdate !GuildMemberUpdateData+    | GuildMembersChunk !GuildMembersChunkData+    | GuildRoleCreate !GuildRoleData+    | GuildRoleUpdate !GuildRoleData+    | GuildRoleDelete !GuildRoleDeleteData+    | InviteCreate !InviteCreateData+    | InviteDelete !InviteDeleteData+    | MessageCreate !Message !(Maybe User)+    | MessageUpdate !UpdatedMessage+    | MessageDelete !MessageDeleteData+    | MessageDeleteBulk !MessageDeleteBulkData+    | MessageReactionAdd !ReactionEvtData+    | MessageReactionRemove !ReactionEvtData+    | MessageReactionRemoveAll !MessageReactionRemoveAllData+    | PresenceUpdate !PresenceUpdateData+    | TypingStart !TypingStartData+    | UserUpdate !User+    | VoiceStateUpdate !VoiceState+    | VoiceServerUpdate !VoiceServerUpdateData+    | WebhooksUpdate !WebhooksUpdateData+    | InteractionCreate !Interaction+    deriving (Show, Generic, CtorName)  data ReadyData = ReadyData-  { v :: Integer-  , user :: User-  , guilds :: [UnavailableGuild]-  , sessionID :: Text-  }-  deriving (Show, Generic)-  deriving (FromJSON) via CalamityJSON ReadyData+    { v :: Integer+    , user :: User+    , guilds :: [UnavailableGuild]+    , sessionID :: Text+    }+    deriving (Show, Generic)+    deriving (FromJSON) via CalamityJSON ReadyData  data ChannelPinsUpdateData = ChannelPinsUpdateData-  { channelID :: Snowflake Channel-  , lastPinTimestamp :: Maybe UTCTime-  }-  deriving (Show, Generic)-  deriving (FromJSON) via CalamityJSON ChannelPinsUpdateData+    { channelID :: Snowflake Channel+    , lastPinTimestamp :: Maybe UTCTime+    }+    deriving (Show, Generic)+    deriving (FromJSON) via CalamityJSON ChannelPinsUpdateData  data GuildEmojisUpdateData = GuildEmojisUpdateData-  { guildID :: Snowflake Guild-  , emojis :: [Emoji]-  }-  deriving (Show, Generic)-  deriving (FromJSON) via CalamityJSON GuildEmojisUpdateData+    { guildID :: Snowflake Guild+    , emojis :: [Emoji]+    }+    deriving (Show, Generic)+    deriving (FromJSON) via CalamityJSON GuildEmojisUpdateData  newtype GuildIntegrationsUpdateData = GuildIntegrationsUpdateData-  { guildID :: Snowflake Guild-  }-  deriving newtype (Show, Generic)-  deriving (FromJSON) via CalamityJSON GuildIntegrationsUpdateData+    { guildID :: Snowflake Guild+    }+    deriving newtype (Show, Generic)+    deriving (FromJSON) via CalamityJSON GuildIntegrationsUpdateData  data GuildMemberRemoveData = GuildMemberRemoveData-  { guildID :: Snowflake Guild-  , user :: User-  }-  deriving (Show, Generic)-  deriving (FromJSON) via CalamityJSON GuildMemberRemoveData+    { guildID :: Snowflake Guild+    , user :: User+    }+    deriving (Show, Generic)+    deriving (FromJSON) via CalamityJSON GuildMemberRemoveData  data GuildMemberUpdateData = GuildMemberUpdateData-  { guildID :: Snowflake Guild-  , roles :: AesonVector (Snowflake Role)-  , user :: User-  , nick :: Maybe Text-  }-  deriving (Show, Generic)-  deriving (FromJSON) via CalamityJSON GuildMemberUpdateData+    { guildID :: Snowflake Guild+    , roles :: AesonVector (Snowflake Role)+    , user :: User+    , nick :: Maybe Text+    }+    deriving (Show, Generic)+    deriving (FromJSON) via CalamityJSON GuildMemberUpdateData  data GuildMembersChunkData = GuildMembersChunkData-  { guildID :: Snowflake Guild-  , members :: [Member]-  }-  deriving (Show, Generic)+    { guildID :: Snowflake Guild+    , members :: [Member]+    }+    deriving (Show, Generic)  instance FromJSON GuildMembersChunkData where-  parseJSON = withObject "GuildMembersChunkData" $ \v -> do-    guildID <- v .: "guild_id"+    parseJSON = withObject "GuildMembersChunkData" $ \v -> do+        guildID <- v .: "guild_id" -    members' <- do-      members' <- v .: "members"-      traverse (\m -> parseJSON $ Object (m <> "guild_id" .= guildID)) members'+        members' <- do+            members' <- v .: "members"+            traverse (\m -> parseJSON $ Object (m <> "guild_id" .= guildID)) members' -    pure $ GuildMembersChunkData guildID members'+        pure $ GuildMembersChunkData guildID members'  data GuildRoleData = GuildRoleData-  { guildID :: Snowflake Guild-  , role :: Role-  }-  deriving (Show, Generic)-  deriving (FromJSON) via CalamityJSON GuildRoleData+    { guildID :: Snowflake Guild+    , role :: Role+    }+    deriving (Show, Generic)+    deriving (FromJSON) via CalamityJSON GuildRoleData  data GuildRoleDeleteData = GuildRoleDeleteData-  { guildID :: Snowflake Guild-  , roleID :: Snowflake Role-  }-  deriving (Show, Generic)-  deriving (FromJSON) via CalamityJSON GuildRoleDeleteData+    { guildID :: Snowflake Guild+    , roleID :: Snowflake Role+    }+    deriving (Show, Generic)+    deriving (FromJSON) via CalamityJSON GuildRoleDeleteData  data InviteCreateData = InviteCreateData-  { channelID :: Snowflake Channel-  , code :: Text-  , createdAt :: UTCTime-  , guildID :: Maybe (Snowflake Guild)-  , inviter :: Maybe (Snowflake User)-  , maxAge :: Int-  , maxUses :: Int-  , targetUser :: Maybe (Snowflake User)-  , targetUserType :: Maybe Integer-  , temporary :: Bool-  , uses :: Integer-  }-  deriving (Show, Generic)-  deriving-    (FromJSON)-    via WithSpecialCases-          '["inviter" `ExtractFieldFrom` "id", "targetUser" `ExtractFieldFrom` "id"]-          InviteCreateData+    { channelID :: Snowflake Channel+    , code :: Text+    , createdAt :: UTCTime+    , guildID :: Maybe (Snowflake Guild)+    , inviter :: Maybe (Snowflake User)+    , maxAge :: Int+    , maxUses :: Int+    , targetUser :: Maybe (Snowflake User)+    , targetUserType :: Maybe Integer+    , temporary :: Bool+    , uses :: Integer+    }+    deriving (Show, Generic)+    deriving+        (FromJSON)+        via WithSpecialCases+                '["inviter" `ExtractFieldFrom` "id", "targetUser" `ExtractFieldFrom` "id"]+                InviteCreateData  data InviteDeleteData = InviteDeleteData-  { channelID :: Snowflake Channel-  , guildID :: Maybe (Snowflake Guild)-  , code :: Text-  }-  deriving (Show, Generic)-  deriving (FromJSON) via CalamityJSON InviteDeleteData+    { channelID :: Snowflake Channel+    , guildID :: Maybe (Snowflake Guild)+    , code :: Text+    }+    deriving (Show, Generic)+    deriving (FromJSON) via CalamityJSON InviteDeleteData  data MessageDeleteData = MessageDeleteData-  { id :: Snowflake Message-  , channelID :: Snowflake Channel-  , guildID :: Snowflake Guild-  }-  deriving (Show, Generic)-  deriving (FromJSON) via CalamityJSON MessageDeleteData+    { id :: Snowflake Message+    , channelID :: Snowflake Channel+    , guildID :: Snowflake Guild+    }+    deriving (Show, Generic)+    deriving (FromJSON) via CalamityJSON MessageDeleteData  data MessageDeleteBulkData = MessageDeleteBulkData-  { guildID :: Snowflake Guild-  , channelID :: Snowflake Channel-  , ids :: [Snowflake Message]-  }-  deriving (Show, Generic)-  deriving (FromJSON) via CalamityJSON MessageDeleteBulkData+    { guildID :: Snowflake Guild+    , channelID :: Snowflake Channel+    , ids :: [Snowflake Message]+    }+    deriving (Show, Generic)+    deriving (FromJSON) via CalamityJSON MessageDeleteBulkData  data MessageReactionRemoveAllData = MessageReactionRemoveAllData-  { channelID :: Snowflake Channel-  , messageID :: Snowflake Message-  , guildID :: Maybe (Snowflake Guild)-  }-  deriving (Show, Generic)-  deriving (FromJSON) via CalamityJSON MessageReactionRemoveAllData+    { channelID :: Snowflake Channel+    , messageID :: Snowflake Message+    , guildID :: Maybe (Snowflake Guild)+    }+    deriving (Show, Generic)+    deriving (FromJSON) via CalamityJSON MessageReactionRemoveAllData  data PresenceUpdateData = PresenceUpdateData-  { userID :: Snowflake User-  , presence :: Presence-  }-  deriving (Show, Generic)+    { userID :: Snowflake User+    , presence :: Presence+    }+    deriving (Show, Generic)  instance FromJSON PresenceUpdateData where-  parseJSON = withObject "PresenceUpdate" $ \v -> do-    user <- (v .: "user") >>= (.: "id")-    presence <- parseJSON $ Object v-    pure $ PresenceUpdateData user presence+    parseJSON = withObject "PresenceUpdate" $ \v -> do+        user <- (v .: "user") >>= (.: "id")+        presence <- parseJSON $ Object v+        pure $ PresenceUpdateData user presence  data TypingStartData = TypingStartData-  { channelID :: Snowflake Channel-  , guildID :: Maybe (Snowflake Guild)-  , userID :: Snowflake User-  , timestamp :: UnixTimestamp-  }-  deriving (Show, Generic)-  deriving (FromJSON) via CalamityJSON TypingStartData+    { channelID :: Snowflake Channel+    , guildID :: Maybe (Snowflake Guild)+    , userID :: Snowflake User+    , timestamp :: UnixTimestamp+    }+    deriving (Show, Generic)+    deriving (FromJSON) via CalamityJSON TypingStartData  newtype VoiceServerUpdateData = VoiceServerUpdateData Value-  deriving newtype (Show, Generic)-  deriving newtype (ToJSON, FromJSON)+    deriving newtype (Show, Generic)+    deriving newtype (ToJSON, FromJSON)  newtype WebhooksUpdateData = WebhooksUpdateData Value-  deriving newtype (Show, Generic)-  deriving newtype (ToJSON, FromJSON)+    deriving newtype (Show, Generic)+    deriving newtype (ToJSON, FromJSON)  data ReactionEvtData = ReactionEvtData-  { userID :: Snowflake User-  , channelID :: Snowflake Channel-  , messageID :: Snowflake Message-  , guildID :: Maybe (Snowflake Guild)-  , emoji :: RawEmoji-  }-  deriving (Eq, Show, Generic)-  deriving (ToJSON, FromJSON) via CalamityJSON ReactionEvtData-  deriving (HasID User) via HasIDField "userID" ReactionEvtData-  deriving (HasID Channel) via HasIDField "channelID" ReactionEvtData-  deriving (HasID Message) via HasIDField "messageID" ReactionEvtData+    { userID :: Snowflake User+    , channelID :: Snowflake Channel+    , messageID :: Snowflake Message+    , guildID :: Maybe (Snowflake Guild)+    , emoji :: RawEmoji+    }+    deriving (Eq, Show, Generic)+    deriving (ToJSON, FromJSON) via CalamityJSON ReactionEvtData+    deriving (HasID User) via HasIDField "userID" ReactionEvtData+    deriving (HasID Channel) via HasIDField "channelID" ReactionEvtData+    deriving (HasID Message) via HasIDField "messageID" ReactionEvtData

@@ -1,49 +1,55 @@-{-# LANGUAGE NoDeriveAnyClass #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoDeriveAnyClass #-}  -- | Discord gateway intents-module Calamity.Gateway.Intents-    ( Intents(..)-    , defaultIntents-    , intentGuilds-    , intentGuildMembers-    , intentGuildBans-    , intentGuildEmojis-    , intentGuildIntegrations-    , intentGuildWebhooks-    , intentGuildInvites-    , intentGuildVoiceStates-    , intentGuildPresences-    , intentGuildMessages-    , intentGuildMessageReactions-    , intentGuildMessageTyping-    , intentDirectMessages-    , intentDirectMessageReactions-    , intentDirectMessageTyping ) where+module Calamity.Gateway.Intents (+    Intents (..),+    defaultIntents,+    intentGuilds,+    intentGuildMembers,+    intentGuildBans,+    intentGuildEmojis,+    intentGuildIntegrations,+    intentGuildWebhooks,+    intentGuildInvites,+    intentGuildVoiceStates,+    intentGuildPresences,+    intentGuildMessages,+    intentGuildMessageReactions,+    intentGuildMessageTyping,+    intentDirectMessages,+    intentDirectMessageReactions,+    intentDirectMessageTyping,+) where -import           Data.Aeson    ( ToJSON )-import           Data.Bits-import           Data.Flags    (allBut, (.+.))-import           Data.Flags.TH-import           Data.Word-import           Data.Default.Class+import Data.Aeson (ToJSON)+import Data.Bits (Bits (shiftL))+import Data.Default.Class (Default (..))+import Data.Flags (allBut, (.+.))+import Data.Flags.TH (bitmaskWrapper)+import Data.Word (Word32) -$(bitmaskWrapper "Intents" ''Word32 []-   [ ("intentGuilds", 1 `shiftL` 0)-   , ("intentGuildMembers", 1 `shiftL` 1)-   , ("intentGuildBans", 1 `shiftL` 2)-   , ("intentGuildEmojis", 1 `shiftL` 3)-   , ("intentGuildIntegrations", 1 `shiftL` 4)-   , ("intentGuildWebhooks", 1 `shiftL` 5)-   , ("intentGuildInvites", 1 `shiftL` 6)-   , ("intentGuildVoiceStates", 1 `shiftL` 7)-   , ("intentGuildPresences", 1 `shiftL` 8)-   , ("intentGuildMessages", 1 `shiftL` 9)-   , ("intentGuildMessageReactions", 1 `shiftL` 10)-   , ("intentGuildMessageTyping", 1 `shiftL` 11)-   , ("intentDirectMessages", 1 `shiftL` 12)-   , ("intentDirectMessageReactions", 1 `shiftL` 13)-   , ("intentDirectMessageTyping", 1 `shiftL` 14)])+$( bitmaskWrapper+    "Intents"+    ''Word32+    []+    [ ("intentGuilds", 1 `shiftL` 0)+    , ("intentGuildMembers", 1 `shiftL` 1)+    , ("intentGuildBans", 1 `shiftL` 2)+    , ("intentGuildEmojis", 1 `shiftL` 3)+    , ("intentGuildIntegrations", 1 `shiftL` 4)+    , ("intentGuildWebhooks", 1 `shiftL` 5)+    , ("intentGuildInvites", 1 `shiftL` 6)+    , ("intentGuildVoiceStates", 1 `shiftL` 7)+    , ("intentGuildPresences", 1 `shiftL` 8)+    , ("intentGuildMessages", 1 `shiftL` 9)+    , ("intentGuildMessageReactions", 1 `shiftL` 10)+    , ("intentGuildMessageTyping", 1 `shiftL` 11)+    , ("intentDirectMessages", 1 `shiftL` 12)+    , ("intentDirectMessageReactions", 1 `shiftL` 13)+    , ("intentDirectMessageTyping", 1 `shiftL` 14)+    ]+ )  deriving via Word32 instance ToJSON Intents @@ -53,4 +59,4 @@  -- | Default intents are all but the privileged intents: members and intents instance Default Intents where-  def = defaultIntents+    def = defaultIntents

@@ -199,7 +199,7 @@     let host' = fromMaybe host $ L.stripPrefix "wss://" host     info [fmt|starting up shard {shardID shard} of {shardCount shard}|] -    innerLoopVal <- runWebsocket host' "/?v=8&encoding=json" innerloop+    innerLoopVal <- runWebsocket host' "/?v=9&encoding=json" innerloop      case innerLoopVal of       Just ShardFlowShutDown -> do

@@ -165,7 +165,7 @@ routeKey Route {key, channelID, guildID} = (key, channelID, guildID)  baseURL :: Url 'Https-baseURL = https "discord.com" /: "api" /: "v8"+baseURL = https "discord.com" /: "api" /: "v9"  buildRoute   :: forall (reqs :: [(RequirementType, RouteRequirement)])

@@ -79,7 +79,7 @@   runSpecialCases :: Proxy a -> Object -> Parser Object  instance RunSpecialCase '[] where-  runSpecialCases _ = pure . id+  runSpecialCases _ = pure  instance (RunSpecialCase xs, PerformAction action) => RunSpecialCase (action : xs) where   runSpecialCases _ o = do

@@ -1,98 +1,127 @@ -- | Updateable objects-module Calamity.Internal.Updateable-    ( Updateable(..) ) where--import           Calamity.Internal.Utils-import           Calamity.Types.Model.Channel-import           Calamity.Types.Model.Channel.UpdatedMessage-import           Calamity.Types.Model.Guild.Guild-import           Calamity.Types.Model.User--import           Control.Lens--import           Data.Generics.Product.Fields-import           Data.Maybe+module Calamity.Internal.Updateable (Updateable (..)) where -import           GHC.TypeLits+import Calamity.Internal.Utils+import Calamity.Types.Model.Channel+import Calamity.Types.Model.Channel.UpdatedMessage+import Calamity.Types.Model.Guild.Guild+import Calamity.Types.Model.User+import Control.Lens+import Data.Generics.Product.Fields+import Data.Maybe+import GHC.TypeLits  class Updateable a where-  type Updated a-  type Updated a = a+    type Updated a+    type Updated a = a -  update :: Updated a -> a -> a+    update :: Updated a -> a -> a  -- | sets original field to new field setF :: forall (f :: Symbol) o n b. (HasField' f o b, HasField' f o b, HasField' f n b) => n -> o -> o-setF n = field' @f .~ (n ^. field' @f)+setF n = field' @f .~ n ^. field' @f  -- | sets original field to unwrapped new field if new field is not Nothing-mergeF :: forall (f :: Symbol) o n b. (HasField' f o b, HasField' f o b, HasField' f n (Maybe b)) => o -> n -> o -> o-mergeF o n = field' @f .~ fromMaybe (o ^. field' @f) (n ^. field' @f)+mergeF :: forall (f :: Symbol) o n b. (HasField' f o b, HasField' f o b, HasField' f n (Maybe b)) => n -> o -> o+mergeF n = field' @f %~ \oldv -> fromMaybe oldv (n ^. field' @f) --- | sets original field to new field if new field is not Nothing-mergeF' :: forall (f :: Symbol) o n b. (HasField' f o (Maybe b), HasField' f n (Maybe b)) => o -> n -> o -> o-mergeF' o n = field' @f .~ lastMaybe (o ^. field' @f) (n ^. field' @f)+-- | sets original field to new field if new field is not nothing+mergeF' ::+    forall (f :: Symbol) old new v.+    ( HasField' f old (Maybe v)+    , HasField' f new (Maybe v)+    ) =>+    new ->+    old ->+    old+mergeF' new = field' @f %~ \oldv -> lastMaybe oldv (new ^. field' @f) +-- | sets original field to new field if new field was present+updateNullableDest ::+    forall (f :: Symbol) old new v.+    ( HasField' f old (Maybe v)+    , HasField' f new (Maybe (MaybeNull v))+    ) =>+    new ->+    old ->+    old+updateNullableDest new = case new ^. field' @f of+    Just (NotNull x) -> field' @f ?~ x+    Just WasNull -> field' @f .~ Nothing+    Nothing -> Prelude.id++-- NOTE: afaik only messages get partial updates instance Updateable Message where-  type Updated Message = UpdatedMessage+    type Updated Message = UpdatedMessage -  update n o = o-    & mergeF @"content" o n-    & setF @"editedTimestamp" n-    & mergeF @"tts" o n-    & mergeF @"mentionEveryone" o n-    & mergeF @"mentions" o n-    & mergeF @"mentionRoles" o n-    & mergeF' @"mentionChannels" o n-    & mergeF @"attachments" o n-    & mergeF @"embeds" o n-    & mergeF @"reactions" o n-    & mergeF @"pinned" o n+    update n o = o+      & mergeF @"content" n+      & updateNullableDest @"editedTimestamp" n+      & mergeF @"tts" n+      & mergeF @"mentionEveryone" n+      & mergeF @"mentions" n+      & mergeF @"mentionRoles" n+      & mergeF' @"mentionChannels" n+      & mergeF @"attachments" n+      & mergeF @"embeds" n+      & mergeF @"reactions" n+      & mergeF @"pinned" n+      & updateNullableDest @"webhookID" n+      & mergeF @"type_" n+      & updateNullableDest @"activity" n+      & updateNullableDest @"application" n+      & updateNullableDest @"messageReference" n+      & mergeF @"flags" n+      & updateNullableDest @"stickers" n+      & updateNullableDest @"referencedMessage" n+      & updateNullableDest @"interaction" n+      & mergeF @"components" n  instance Updateable Channel where-  update n _ = n+    update n _ = n  instance Updateable DMChannel where-  update n _ = n+    update n _ = n  instance Updateable GuildChannel where-  update n _ = n+    update n _ = n  instance Updateable Guild where-  type Updated Guild = UpdatedGuild+    type Updated Guild = UpdatedGuild -  -- For updating guild we just put in the non-present data from-  update n o = o-    & setF @"name" n-    & setF @"icon" n-    & setF @"splash" n-    & setF @"owner" n-    & setF @"ownerID" n-    & mergeF @"permissions" o n-    & setF @"region" n-    & setF @"afkChannelID" n-    & setF @"afkTimeout" n-    & mergeF @"embedEnabled" o n-    & setF @"embedChannelID" n-    & setF @"verificationLevel" n-    & setF @"defaultMessageNotifications" n-    & setF @"explicitContentFilter" n-    & setF @"roles" n-    & setF @"features" n-    & setF @"mfaLevel" n-    & setF @"applicationID" n-    & mergeF @"widgetEnabled" o n-    & setF @"widgetChannelID" n-    & setF @"systemChannelID" n+    update n o =+        o+            & setF @"name" n+            & setF @"icon" n+            & setF @"splash" n+            & setF @"owner" n+            & setF @"ownerID" n+            & mergeF @"permissions" n+            & setF @"region" n+            & setF @"afkChannelID" n+            & setF @"afkTimeout" n+            & mergeF @"embedEnabled" n+            & setF @"embedChannelID" n+            & setF @"verificationLevel" n+            & setF @"defaultMessageNotifications" n+            & setF @"explicitContentFilter" n+            & setF @"roles" n+            & setF @"features" n+            & setF @"mfaLevel" n+            & setF @"applicationID" n+            & mergeF @"widgetEnabled" n+            & setF @"widgetChannelID" n+            & setF @"systemChannelID" n  instance Updateable User where-  update n o = o-    & setF @"username" n-    & setF @"discriminator" n-    & mergeF' @"bot" o n-    & mergeF' @"avatar" o n-    & mergeF' @"mfaEnabled" o n-    & mergeF' @"verified" o n-    & mergeF' @"email" o n-    & mergeF' @"flags" o n-    & mergeF' @"premiumType" o n+    update n o =+        o+            & setF @"username" n+            & setF @"discriminator" n+            & mergeF' @"bot" n+            & mergeF' @"avatar" n+            & mergeF' @"mfaEnabled" n+            & mergeF' @"verified" n+            & mergeF' @"email" n+            & mergeF' @"flags" n+            & mergeF' @"premiumType" n

@@ -19,12 +19,14 @@   DefaultingMap (..),   AesonVector (..),   CalamityFromStringShow (..),+  MaybeNull (..), ) where  import Calamity.Internal.RunIntoIO import Calamity.Types.LogEff import Control.Applicative import Data.Aeson+import Data.Aeson.Encoding (null_) import Data.Default.Class import qualified Data.Map as M import Data.Semigroup (Last (..))@@ -33,6 +35,8 @@ import qualified DiPolysemy as Di import qualified Polysemy as P import TextShow+import GHC.Generics+import qualified TextShow.Generic as TSG  {- | Like whileM, but stateful effects are not preserved to mitigate memory leaks @@ -145,3 +149,22 @@ newtype CalamityFromStringShow a = CalamityFromStringShow {unCalamityFromStringShow :: a}   deriving (FromJSON, ToJSON) via a   deriving TextShow via FromStringShow a++-- | An alternative 'Maybe' type that allows us to distinguish between parsed+-- json fields that were null, and fields that didn't exist.+data MaybeNull a+  = WasNull+  | NotNull a+  deriving (Show, Generic)+  deriving (TextShow) via TSG.FromGeneric (MaybeNull a)++instance FromJSON a => FromJSON (MaybeNull a) where+  parseJSON Null = pure WasNull+  parseJSON x = NotNull <$> parseJSON x++instance ToJSON a => ToJSON (MaybeNull a) where+  toJSON WasNull = Null+  toJSON (NotNull x) = toJSON x++  toEncoding WasNull = null_+  toEncoding (NotNull x) = toEncoding x

@@ -1,13 +1,12 @@ -- | Types of channels-module Calamity.Types.Model.Channel.ChannelType-    ( ChannelType(..) ) where+module Calamity.Types.Model.Channel.ChannelType (ChannelType (..)) where -import           Data.Aeson-import           Data.Scientific+import Data.Aeson+import Data.Scientific -import           GHC.Generics+import GHC.Generics -import           TextShow+import TextShow import qualified TextShow.Generic as TSG  -- Thanks sbrg (https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hsfield#L182)@@ -17,15 +16,15 @@   | GuildVoiceType   | GroupDMType   | GuildCategoryType-  deriving ( Eq, Generic, Show, Enum )-  deriving ( TextShow ) via TSG.FromGeneric ChannelType+  deriving (Eq, Generic, Show, Enum)+  deriving (TextShow) via TSG.FromGeneric ChannelType  instance ToJSON ChannelType where   toJSON t = Number $ fromIntegral (fromEnum t)  instance FromJSON ChannelType where   parseJSON = withScientific "ChannelType" $ \n -> case toBoundedInteger @Int n of-    Just !v  -> case v of+    Just v -> case v of       0 -> pure GuildTextType       1 -> pure DMType       2 -> pure GuildVoiceType

@@ -0,0 +1,120 @@+-- | Message components+module Calamity.Types.Model.Channel.Component (+    Component (..),+    Button (..),+    button,+    button',+    ButtonStyle (..),+    ComponentType (..),+    componentType,+) where++import Calamity.Internal.AesonThings+import Calamity.Types.Model.Guild.Emoji+import Data.Aeson+import Data.Scientific (toBoundedInteger)+import qualified Data.Text.Lazy as L+import GHC.Generics+import TextShow+import qualified TextShow.Generic as TSG++data Button = Button+    { style :: ButtonStyle+    , label :: Maybe L.Text+    , emoji :: Maybe (Partial Emoji)+    , customID :: Maybe L.Text+    , url :: Maybe L.Text+    , disabled :: Bool+    }+    deriving (Show, Generic)+    deriving (TextShow) via TSG.FromGeneric Button+    deriving (ToJSON) via CalamityJSONKeepNothing Button+    deriving+        (FromJSON)+        via WithSpecialCases+                '["disabled" `IfNoneThen` DefaultToFalse]+                Button++data ButtonStyle+    = ButtonPrimary+    | ButtonSecondary+    | ButtonSuccess+    | ButtonDanger+    | ButtonLink+    deriving (Show, Generic)+    deriving (TextShow) via TSG.FromGeneric ButtonStyle++{- | Constuct a non-disabled 'Button' with the given 'ButtonStyle', all other+ fields are set to 'Nothing'+-}+button :: ButtonStyle -> Button+button s = Button s Nothing Nothing Nothing Nothing False++{- | Constuct a non-disabled 'Button' with the given 'ButtonStyle' and label,+ all other fields are set to 'Nothing'+-}+button' :: ButtonStyle -> L.Text -> Button+button' s l = Button s (Just l) Nothing Nothing Nothing False++instance ToJSON ButtonStyle where+    toJSON t = toJSON @Int $ case t of+        ButtonPrimary -> 1+        ButtonSecondary -> 2+        ButtonSuccess -> 3+        ButtonDanger -> 4+        ButtonLink -> 5++instance FromJSON ButtonStyle where+    parseJSON = withScientific "ChannelType" $ \n -> case toBoundedInteger @Int n of+        Just v -> case v of+            1 -> pure ButtonPrimary+            2 -> pure ButtonSecondary+            3 -> pure ButtonSuccess+            4 -> pure ButtonDanger+            5 -> pure ButtonLink+            _ -> fail $ "Invalid ButtonStyle: " <> show n+        Nothing -> fail $ "Invalid ButtonStyle: " <> show n++data Component+    = Button' Button+    | ActionRow' [Component]+    deriving (Show, Generic)+    deriving (TextShow) via TSG.FromGeneric Component++instance ToJSON Component where+    toJSON t =+        let (Object inner, type_) = case t of+                ActionRow' xs -> (Object ("components" .= xs), 1 :: Int)+                Button' b -> (toJSON b, 2 :: Int)+         in Object (inner <> ("type" .= type_))++instance FromJSON Component where+    parseJSON = withObject "Component" $ \v -> do+        type_ :: Int <- v .: "type"++        case type_ of+            1 -> do+                ActionRow' <$> v .: "components"+            2 -> Button' <$> parseJSON (Object v)+            _ -> fail $ "Invalid ComponentType: " <> show type_++componentType :: Component -> ComponentType+componentType (ActionRow' _) = ActionRowType+componentType (Button' _) = ButtonType++data ComponentType+    = ActionRowType+    | ButtonType+    deriving (Show, Generic)+    deriving (TextShow) via TSG.FromGeneric ComponentType++instance ToJSON ComponentType where+    toJSON x = toJSON @Int $ case x of+        ActionRowType -> 1+        ButtonType -> 2++instance FromJSON ComponentType where+    parseJSON = withScientific "ComponentType" $ \n -> case toBoundedInteger @Int n of+        Just 1 -> pure ActionRowType+        Just 2 -> pure ButtonType+        _ -> fail $ "Invalid ComponentType: " <> show n

@@ -10,6 +10,7 @@ import Calamity.Internal.Utils import {-# SOURCE #-} Calamity.Types.Model.Channel import Calamity.Types.Model.Channel.Attachment+import Calamity.Types.Model.Channel.Component import Calamity.Types.Model.Channel.Embed import Calamity.Types.Model.Channel.Reaction import Calamity.Types.Model.Channel.Webhook@@ -43,7 +44,7 @@   , attachments :: ![Attachment]   , embeds :: ![Embed]   , reactions :: ![Reaction]-  , nonce :: Maybe (Snowflake Message)+  , nonce :: Maybe (CalamityFromStringShow Value)   , pinned :: Bool   , webhookID :: Maybe (Snowflake Webhook)   , type_ :: !MessageType@@ -54,6 +55,7 @@   , stickers :: Maybe [CalamityFromStringShow Object]   , referencedMessage :: Maybe Message   , interaction :: Maybe (CalamityFromStringShow Object)+  , components :: [Component]   }   deriving (Generic)   deriving (TextShow) via TSG.FromGeneric Message'@@ -64,6 +66,7 @@            , "mentions" `ExtractArrayField` "id"            , "mention_channels" `ExtractArrayField` "id"            , "reactions" `IfNoneThen` DefaultToEmptyArray+           , "components" `IfNoneThen` DefaultToEmptyArray            ]           Message' @@ -83,7 +86,7 @@   , attachments :: ![Attachment]   , embeds :: ![Embed]   , reactions :: ![Reaction]-  , nonce :: Maybe (Snowflake Message)+  , nonce :: Maybe Value    , pinned :: Bool   , webhookID :: Maybe (Snowflake Webhook)   , type_ :: !MessageType@@ -94,8 +97,9 @@   , stickers :: Maybe [Object]   , referencedMessage :: Maybe Message   , interaction :: Maybe Object+  , components :: [Component]   }-  deriving (Eq, Show, Generic)+  deriving (Show, Generic)   deriving (TextShow, FromJSON) via OverriddenVia Message Message'   deriving (HasID Message) via HasIDField "id" Message   deriving (HasID Channel) via HasIDField "channelID" Message@@ -141,7 +145,7 @@  instance FromJSON MessageType where   parseJSON = withScientific "MessageType" $ \n -> case toBoundedInteger @Int n of-    Just !v -> case v of+    Just v -> case v of       0 -> pure Default       1 -> pure RecipientAdd       2 -> pure RecipientRemove

@@ -7,7 +7,6 @@ data Message  instance Show Message-instance Eq Message  data MessageType 

@@ -17,12 +17,14 @@ import GHC.Generics import TextShow import qualified TextShow.Generic as TSG+import Data.Word+import Calamity.Types.Model.Channel.Component  data UpdatedMessage' = UpdatedMessage'     { id :: Snowflake Message     , channelID :: Snowflake Channel     , content :: Maybe Text-    , editedTimestamp :: Maybe (CalamityFromStringShow UTCTime)+    , editedTimestamp :: Maybe (MaybeNull (CalamityFromStringShow UTCTime))     , tts :: Maybe Bool     , mentionEveryone :: Maybe Bool     , mentions :: Maybe (AesonVector (Snowflake User))@@ -32,6 +34,16 @@     , embeds :: Maybe [Embed]     , reactions :: Maybe [Reaction]     , pinned :: Maybe Bool+    , webhookID :: Maybe (MaybeNull (Snowflake Webhook))+    , type_ :: Maybe MessageType+    , activity :: Maybe (MaybeNull (CalamityFromStringShow Object))+    , application :: Maybe (MaybeNull (CalamityFromStringShow Object))+    , messageReference :: Maybe (MaybeNull MessageReference)+    , flags :: Maybe Word64+    , stickers :: Maybe (MaybeNull [CalamityFromStringShow Object])+    , referencedMessage :: Maybe (MaybeNull Message)+    , interaction :: Maybe (MaybeNull (CalamityFromStringShow Object))+    , components :: Maybe [Component]     }     deriving (Generic)     deriving (TextShow) via TSG.FromGeneric UpdatedMessage'@@ -48,7 +60,7 @@     { id :: Snowflake Message     , channelID :: Snowflake Channel     , content :: Maybe Text-    , editedTimestamp :: Maybe UTCTime+    , editedTimestamp :: Maybe (MaybeNull UTCTime)     , tts :: Maybe Bool     , mentionEveryone :: Maybe Bool     , mentions :: Maybe (UV.Vector (Snowflake User))@@ -58,8 +70,18 @@     , embeds :: Maybe [Embed]     , reactions :: Maybe [Reaction]     , pinned :: Maybe Bool+    , webhookID :: Maybe (MaybeNull (Snowflake Webhook))+    , type_ :: Maybe MessageType+    , activity :: Maybe (MaybeNull Object)+    , application :: Maybe (MaybeNull Object)+    , messageReference :: Maybe (MaybeNull MessageReference)+    , flags :: Maybe Word64+    , stickers :: Maybe (MaybeNull [Object])+    , referencedMessage :: Maybe (MaybeNull Message)+    , interaction :: Maybe (MaybeNull Object)+    , components :: Maybe [Component]     }-    deriving (Eq, Show, Generic)+    deriving (Show, Generic)     deriving (TextShow, FromJSON) via OverriddenVia UpdatedMessage UpdatedMessage'     deriving (HasID Message) via HasIDField "id" UpdatedMessage     deriving (HasID Channel) via HasIDField "channelID" UpdatedMessage

@@ -185,7 +185,7 @@  instance FromJSON AuditLogAction where   parseJSON = withScientific "AuditLogAction" $ \n -> case toBoundedInteger @Int n of-    Just !v  -> case v of --  no safe toEnum :S+    Just v  -> case v of --  no safe toEnum :S       1  -> pure GUILD_UPDATE       10 -> pure CHANNEL_CREATE       11 -> pure CHANNEL_UPDATE

@@ -0,0 +1,101 @@+-- | Discord Interactions+module Calamity.Types.Model.Interaction (+    Interaction (..),+    ApplicationCommandInteractionData (..),+    ApplicationCommandInteractionDataResolved (..),+    InteractionType (..),+) where++import Calamity.Internal.AesonThings+import Calamity.Internal.OverriddenVia+import Calamity.Internal.Utils+import Calamity.Types.Model.Channel (Channel)+import Calamity.Types.Model.Channel.Component+import Calamity.Types.Model.Channel.Message (Message)+import Calamity.Types.Model.Guild (Guild, Role)+import Calamity.Types.Model.Guild.Member (Member)+import Calamity.Types.Model.User (User)+import Calamity.Types.Snowflake+import Data.Aeson+import qualified Data.HashMap.Strict as H+import Data.Scientific (toBoundedInteger)+import qualified Data.Text.Lazy as L+import GHC.Generics+import TextShow+import qualified TextShow.Generic as TSG++data Interaction = Interaction+    { id :: Snowflake Interaction+    , applicationID :: Snowflake ()+    , type_ :: InteractionType+    , data_ :: Maybe ApplicationCommandInteractionData+    , guildID :: Maybe (Snowflake Guild)+    , channelID :: Maybe (Snowflake Channel)+    , member :: Maybe Member+    , user :: Maybe User+    , token :: L.Text+    , version :: Int+    , message :: Maybe Message+    }+    deriving (Show, Generic)+    deriving (TextShow) via TSG.FromGeneric Interaction+    deriving (FromJSON) via CalamityJSON Interaction++data ApplicationCommandInteractionData = ApplicationCommandInteractionData+    { id :: Snowflake () -- no Command type yet+    , name :: L.Text+    , resolved :: Maybe ApplicationCommandInteractionDataResolved+    , -- , options :: [ApplicationCommandInteractionDataOptions]+      -- No commands yet+      customID :: L.Text+    , componentType :: ComponentType+    }+    deriving (Show, Generic)+    deriving (TextShow) via TSG.FromGeneric ApplicationCommandInteractionData+    deriving (FromJSON) via CalamityJSON ApplicationCommandInteractionData++data ApplicationCommandInteractionDataResolved' = ApplicationCommandInteractionDataResolved'+    { users :: CalamityFromStringShow (H.HashMap (Snowflake User) User)+    , members :: CalamityFromStringShow (H.HashMap (Snowflake Member) Member)+    , roles :: CalamityFromStringShow (H.HashMap (Snowflake Role) Role)+    , channels :: CalamityFromStringShow (H.HashMap (Snowflake Channel) Channel)+    }+    deriving (Generic)+    deriving (TextShow) via TSG.FromGeneric ApplicationCommandInteractionDataResolved'+    deriving (FromJSON) via CalamityJSON ApplicationCommandInteractionDataResolved'++data ApplicationCommandInteractionDataResolved = ApplicationCommandInteractionDataResolved+    { users :: H.HashMap (Snowflake User) User+    , members :: H.HashMap (Snowflake Member) Member+    , roles :: H.HashMap (Snowflake Role) Role+    , channels :: H.HashMap (Snowflake Channel) Channel+    }+    deriving (Show, Generic)+    deriving+        (TextShow, FromJSON)+        via OverriddenVia ApplicationCommandInteractionDataResolved ApplicationCommandInteractionDataResolved'++data InteractionType+    = PingType+    | ApplicationCommandType+    | MessageComponentType+    deriving (Show, Generic)+    deriving (TextShow) via TSG.FromGeneric InteractionType++-- instance ToJSON InteractionType where+--     toJSON x = toJSON @Int $ case x of+--         PingType -> 1+--         ApplicationCommandType -> 2+--         MessageComponentType -> 3++--     toEncoding x = toEncoding @Int $ case x of+--         PingType -> 1+--         ApplicationCommandType -> 2+--         MessageComponentType -> 3++instance FromJSON InteractionType where+    parseJSON = withScientific "InteractionType" $ \n -> case toBoundedInteger @Int n of+        Just 1 -> pure PingType+        Just 2 -> pure ApplicationCommandType+        Just 3 -> pure MessageComponentType+        _ -> fail $ "Invalid InteractionType: " <> show n

@@ -41,7 +41,7 @@  instance FromJSON ActivityType where   parseJSON = withScientific "ActivityType" $ \n -> case toBoundedInteger @Int n of-    Just !v -> case v of+    Just v -> case v of       0 -> pure Game       1 -> pure Streaming       2 -> pure Listening

@@ -31,7 +31,7 @@   { fromSnowflake :: Word64   }   deriving ( Generic, Eq, Ord, Data )-  deriving ( Show, TextShow ) via Word64+  deriving newtype ( Show, TextShow, FromJSONKey )   deriving newtype ( NFData, ToJSONKey, U.Unboxable )  -- I'm pretty sure that Word64's hash just being 'fromIntegral' is a bad idea when

@@ -1,5 +1,13 @@ # Changelog for Calamity +## 0.1.30.3+++ Added models for interactions and components +  (these are still WIP in this version).++ The 'types' help no longer shows in command help if the command has+  no parameters.++ Added a HasID instance for FullContext and LightContext types.+ ## 0.1.30.2  + Removed all the orphan instances from the library.

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           calamity-version:        0.1.30.2+version:        0.1.30.3 synopsis:       A library for writing discord bots in haskell description:    Please see the README on GitHub at <https://github.com/simmsb/calamity#readme> category:       Network, Web@@ -85,6 +85,7 @@       Calamity.Types.Model.Channel       Calamity.Types.Model.Channel.Attachment       Calamity.Types.Model.Channel.ChannelType+      Calamity.Types.Model.Channel.Component       Calamity.Types.Model.Channel.DM       Calamity.Types.Model.Channel.Embed       Calamity.Types.Model.Channel.Group@@ -107,6 +108,7 @@       Calamity.Types.Model.Guild.Permissions       Calamity.Types.Model.Guild.Role       Calamity.Types.Model.Guild.UnavailableGuild+      Calamity.Types.Model.Interaction       Calamity.Types.Model.Presence       Calamity.Types.Model.Presence.Activity       Calamity.Types.Model.Presence.Presence@@ -185,7 +187,7 @@     , async >=2.2 && <3     , base >=4.13 && <5     , bytestring >=0.10 && <0.12-    , calamity-commands >=0.1.2 && <0.2+    , calamity-commands >=0.1.3 && <0.2     , colour >=2.3.5 && <2.4     , concurrent-extra ==0.7.*     , connection >=0.2.6 && <0.4