calamity 0.4.0.0 → 0.5.0.0

raw patch · 84 files changed

+3694/−2688 lines, 84 filesdep +aeson-opticsdep +opticsdep −generic-lensdep −lensdep −lens-aesondep ~calamity-commandsPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson-optics, optics

Dependencies removed: generic-lens, lens, lens-aeson

Dependency ranges changed: calamity-commands

API changes (from Hackage documentation)

Files

• Calamity/Cache/InMemory.hs +24/−26
• Calamity/Client/Client.hs +47/−34
• Calamity/Client/ShardManager.hs +1/−1
• Calamity/Client/Types.hs +7/−8
• Calamity/Commands/CalamityParsers.hs +5/−5
• Calamity/Commands/Context.hs +15/−11
• Calamity/Commands/Dsl.hs +2/−2
• Calamity/Commands/Utils.hs +10/−6
• Calamity/Gateway/DispatchEvents.hs +276/−176
• Calamity/Gateway/Shard.hs +224/−170
• Calamity/Gateway/Types.hs +226/−194
• Calamity/HTTP/AuditLog.hs +6/−8
• Calamity/HTTP/Channel.hs +125/−41
• Calamity/HTTP/Emoji.hs +25/−11
• Calamity/HTTP/Guild.hs +157/−43
• Calamity/HTTP/Interaction.hs +91/−36
• Calamity/HTTP/Internal/Ratelimit.hs +20/−19
• Calamity/HTTP/Internal/Request.hs +1/−1
• Calamity/HTTP/Internal/Route.hs +95/−92
• Calamity/HTTP/Internal/Types.hs +25/−11
• Calamity/HTTP/Invite.hs +1/−4
• Calamity/HTTP/MiscRoutes.hs +1/−2
• Calamity/HTTP/Reason.hs +1/−5
• Calamity/HTTP/User.hs +26/−13
• Calamity/HTTP/Webhook.hs +59/−14
• Calamity/Interactions/Eff.hs +3/−3
• Calamity/Interactions/Utils.hs +1/−1
• Calamity/Interactions/View.hs +20/−14
• Calamity/Internal/AesonThings.hs +0/−159
• Calamity/Internal/BoundedStore.hs +19/−17
• Calamity/Internal/IntColour.hs +17/−17
• Calamity/Internal/OverriddenVia.hs +0/−36
• Calamity/Internal/ShapeCoerce.hs +0/−37
• Calamity/Internal/SnowflakeMap.hs +30/−34
• Calamity/Internal/UnixTimestamp.hs +0/−4
• Calamity/Internal/Updateable.hs +87/−70
• Calamity/Internal/Utils.hs +36/−18
• Calamity/Metrics/Eff.hs +9/−15
• Calamity/Types/LogEff.hs +6/−5
• Calamity/Types/Model.hs +12/−11
• Calamity/Types/Model/Channel.hs +49/−19
• Calamity/Types/Model/Channel/Attachment.hs +21/−27
• Calamity/Types/Model/Channel/ChannelType.hs +29/−12
• Calamity/Types/Model/Channel/Component.hs +250/−134
• Calamity/Types/Model/Channel/DM.hs +19/−26
• Calamity/Types/Model/Channel/Embed.hs +304/−154
• Calamity/Types/Model/Channel/Group.hs +22/−24
• Calamity/Types/Model/Channel/Guild.hs +28/−56
• Calamity/Types/Model/Channel/Guild/Category.hs +20/−11
• Calamity/Types/Model/Channel/Guild/Text.hs +25/−33
• Calamity/Types/Model/Channel/Guild/Voice.hs +22/−10
• Calamity/Types/Model/Channel/Message.hs +142/−75
• Calamity/Types/Model/Channel/Reaction.hs +26/−11
• Calamity/Types/Model/Channel/UpdatedMessage.hs +60/−69
• Calamity/Types/Model/Channel/Webhook.hs +25/−11
• Calamity/Types/Model/Guild.hs +22/−21
• Calamity/Types/Model/Guild/AuditLog.hs +61/−29
• Calamity/Types/Model/Guild/Ban.hs +23/−20
• Calamity/Types/Model/Guild/Emoji.hs +66/−57
• Calamity/Types/Model/Guild/Guild.hs +70/−67
• Calamity/Types/Model/Guild/Invite.hs +28/−15
• Calamity/Types/Model/Guild/Member.hs +33/−47
• Calamity/Types/Model/Guild/Overwrite.hs +28/−12
• Calamity/Types/Model/Guild/Permissions.hs +81/−71
• Calamity/Types/Model/Guild/Role.hs +34/−32
• Calamity/Types/Model/Guild/UnavailableGuild.hs +24/−16
• Calamity/Types/Model/Interaction.hs +65/−29
• Calamity/Types/Model/Presence.hs +6/−5
• Calamity/Types/Model/Presence/Activity.hs +128/−42
• Calamity/Types/Model/Presence/Presence.hs +40/−16
• Calamity/Types/Model/User.hs +38/−18
• Calamity/Types/Model/Voice.hs +6/−5
• Calamity/Types/Model/Voice/VoiceRegion.hs +32/−11
• Calamity/Types/Model/Voice/VoiceState.hs +38/−12
• Calamity/Types/Partial.hs +1/−2
• Calamity/Types/Snowflake.hs +33/−38
• Calamity/Types/Tellable.hs +5/−6
• Calamity/Types/Token.hs +14/−12
• Calamity/Types/Upgradeable.hs +10/−13
• Calamity/Utils/Message.hs +14/−13
• Calamity/Utils/Permissions.hs +17/−14
• ChangeLog.md +12/−0
• README.md +8/−8
• calamity.cabal +5/−11

@@ -1,3 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+ -- | A 'Cache' handler that operates in memory module Calamity.Cache.InMemory (   runCacheInMemory,@@ -13,33 +15,29 @@ import Calamity.Types.Model.Guild import Calamity.Types.Model.User import Calamity.Types.Snowflake--import Control.Lens+import Control.Applicative+import Data.Functor.Identity import Control.Monad.State.Strict- import Data.Foldable import qualified Data.HashMap.Strict as SH import qualified Data.HashSet as HS import Data.IORef--import Control.DeepSeq-import GHC.Generics-+import Optics import qualified Polysemy as P import qualified Polysemy.AtomicState as P+import Optics.State.Operators ((?=), (%=))  data Cache f = Cache   { user :: Maybe User-  , guilds :: SM.SnowflakeMap Guild-  , dms :: SM.SnowflakeMap DMChannel-  , guildChannels :: SH.HashMap (Snowflake GuildChannel) Guild-  , users :: SM.SnowflakeMap User-  , unavailableGuilds :: HS.HashSet (Snowflake Guild)-  , messages :: f (BS.BoundedStore Message)+  , guilds :: !(SM.SnowflakeMap Guild)+  , dms :: !(SM.SnowflakeMap DMChannel)+  , guildChannels :: !(SH.HashMap (Snowflake GuildChannel) Guild)+  , users :: !(SM.SnowflakeMap User)+  , unavailableGuilds :: !(HS.HashSet (Snowflake Guild))+  , messages :: !(f (BS.BoundedStore Message))   }-  deriving (Generic) -instance NFData (f (BS.BoundedStore Message)) => NFData (Cache f)+$(makeFieldLabelsNoPrefix ''Cache)  type CacheWithMsg = Cache Identity type CacheNoMsg = Cache (Const ())@@ -72,7 +70,7 @@   P.runAtomicStateIORef var $ P.reinterpret runCache' m  runCache' :: (MessageMod (Cache t), P.Member (P.AtomicState (Cache t)) r) => CacheEff m a -> P.Sem r a-runCache' act = P.atomicState' ((swap .) . force . runState $ runCache act)+runCache' act = P.atomicState' ((swap .) . runState $ runCache act)  class MessageMod t where   setMessage' :: Message -> State t ()@@ -81,10 +79,10 @@   delMessage' :: Snowflake Message -> State t ()  instance MessageMod CacheWithMsg where-  setMessage' m = #messages . _Wrapped %= BS.addItem m-  getMessage' mid = use (#messages . _Wrapped . at mid)-  getMessages' = toList <$> use (#messages . _Wrapped)-  delMessage' mid = #messages . _Wrapped %= sans mid+  setMessage' m = #messages % _1 %= BS.addItem m+  getMessage' mid = use (#messages % _1 % at' mid)+  getMessages' = toList <$> use (#messages % _1)+  delMessage' mid = #messages % _1 %= sans mid  instance MessageMod CacheNoMsg where   setMessage' !_ = pure ()@@ -98,23 +96,23 @@ runCache (SetGuild g) = do   #guilds %= SM.insert g   #guildChannels %= SH.filter (\v -> getID @Guild v /= getID @Guild g)-  #guildChannels %= SH.union (SH.fromList $ map (,g) (SM.keys (g ^. #channels)))-runCache (GetGuild gid) = use (#guilds . at gid)-runCache (GetGuildChannel cid) = use (#guildChannels . at cid) <&> (>>= (^. #channels . at cid))+  #guildChannels %= SH.union (SH.fromList $ map (, g) (SM.keys (g ^. #channels)))+runCache (GetGuild gid) = use (#guilds % at' gid)+runCache (GetGuildChannel cid) = use (#guildChannels % at' cid) <&> (>>= (^. #channels % at' cid)) runCache GetGuilds = SM.elems <$> use #guilds runCache (DelGuild gid) = do   #guilds %= sans gid   #guildChannels %= SH.filter (\v -> getID @Guild v /= gid) runCache (SetDM dm) = #dms %= SM.insert dm-runCache (GetDM did) = use (#dms . at did)+runCache (GetDM did) = use (#dms % at' did) runCache GetDMs = SM.elems <$> use #dms runCache (DelDM did) = #dms %= sans did runCache (SetUser u) = #users %= SM.insert u-runCache (GetUser uid) = use (#users . at uid)+runCache (GetUser uid) = use (#users % at' uid) runCache GetUsers = SM.elems <$> use #users runCache (DelUser uid) = #users %= sans uid runCache (SetUnavailableGuild gid) = #unavailableGuilds %= HS.insert gid-runCache (IsUnavailableGuild gid) = use (#unavailableGuilds . contains gid)+runCache (IsUnavailableGuild gid) = use (#unavailableGuilds % contains gid) runCache GetUnavailableGuilds = HS.toList <$> use #unavailableGuilds runCache (DelUnavailableGuild gid) = #unavailableGuilds %= sans gid runCache (SetMessage m) = setMessage' m

@@ -23,7 +23,6 @@ import Calamity.Gateway.Intents import Calamity.Gateway.Types import Calamity.HTTP.Internal.Ratelimit-import Calamity.Types.TokenEff import Calamity.Internal.ConstructorName import Calamity.Internal.RunIntoIO import qualified Calamity.Internal.SnowflakeMap as SM@@ -39,16 +38,15 @@ import qualified Calamity.Types.Model.Voice as V import Calamity.Types.Snowflake import Calamity.Types.Token+import Calamity.Types.TokenEff 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@@ -57,6 +55,7 @@ import qualified Df1 import qualified Di.Core as DC import qualified DiPolysemy as Di+import Optics import qualified Polysemy as P import qualified Polysemy.Async as P import qualified Polysemy.AtomicState as P@@ -446,7 +445,7 @@ handleEvent' eh evt@(ChannelCreate (GuildChannel' chan)) = do   updateCache evt   Just guild <- getGuild (getID chan)-  Just newChan <- pure $ GuildChannel' <$> guild ^. #channels . at (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)@@ -455,14 +454,14 @@   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)+  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)+  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)+  Just oldChan <- pure $ GuildChannel' <$> oldGuild ^. #channels % at (getID chan)   updateCache evt   pure $ map ($ oldChan) (getEventHandlers @'ChannelDeleteEvt eh) handleEvent' eh evt@(ChannelDelete (DMChannel' chan)) = do@@ -471,8 +470,8 @@   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)+--   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@@ -518,41 +517,41 @@ handleEvent' eh evt@(GuildMemberAdd gid member) = do   updateCache evt   Just guild <- getGuild gid-  Just member <- pure $ guild ^. #members . at (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)+  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)+  Just oldMember <- pure $ oldGuild ^. #members % at (getID user)   updateCache evt   Just newGuild <- getGuild guildID-  Just newMember <- pure $ newGuild ^. #members . at (getID user)+  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' = mapMaybe (\mid -> guild ^. #members . at mid) memberIDs+  let members' = mapMaybe (\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)+  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)+  Just oldRole <- pure $ oldGuild ^. #roles % at (getID role)   updateCache evt   Just newGuild <- getGuild guildID-  Just newRole <- pure $ newGuild ^. #roles . at (getID role)+  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+  Just role <- pure $ guild ^. #roles % at roleID   updateCache evt   pure $ map ($ (guild, role)) (getEventHandlers @'GuildRoleDeleteEvt eh) handleEvent' eh (InviteCreate d) = do@@ -632,12 +631,12 @@   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)+  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+  Just newMember <- pure $ newGuild ^. #members % at (coerceSnowflake userID)+  let oldUser :: User = let Member {..} = oldMember in User {..}+      newUser :: User = let Member {..} = newMember in User {..}       userUpdates =         if oldUser /= newUser           then map ($ (oldUser, newUser)) (getEventHandlers @'UserUpdateEvt eh)@@ -647,7 +646,7 @@   case guildID of     Just gid -> do       Just guild <- getGuild gid-      Just chan <- pure $ GuildChannel' <$> guild ^. #channels . at (coerceSnowflake channelID)+      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)@@ -678,7 +677,7 @@ updateCache (ChannelUpdate (DMChannel' chan)) =   updateDM (getID chan) (update chan) updateCache (ChannelUpdate (GuildChannel' chan)) =-  updateGuild (getID chan) (#channels . ix (getID chan) %~ update chan)+  updateGuild (getID chan) (#channels % ix (getID chan) %~ update chan) updateCache (ChannelDelete (DMChannel' chan)) =   delDM (getID chan) updateCache (ChannelDelete (GuildChannel' chan)) =@@ -687,7 +686,7 @@   isNew <- isUnavailableGuild (getID guild)   when isNew $ delUnavailableGuild (getID guild)   setGuild guild-  for_ (SM.fromList (guild ^.. #members . traverse . super)) setUser+  for_ (SM.elems (guild ^. #members)) (\Member {..} -> setUser User {..}) updateCache (GuildUpdate guild) =   updateGuild (getID guild) (update guild) updateCache (GuildDelete UnavailableGuild {id, unavailable}) =@@ -697,13 +696,13 @@ updateCache (GuildEmojisUpdate GuildEmojisUpdateData {guildID, emojis}) =   updateGuild guildID (#emojis .~ SM.fromList emojis) updateCache (GuildMemberAdd gid member) = do-  setUser (member ^. super)-  updateGuild gid (#members . at (getID member) ?~ member)+  setUser $ (\Member {..} -> User {..}) member+  updateGuild gid (#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))+  updateGuild guildID (#members % ix (getID user) %~ (#roles .~ roles) . (#nick .~ nick)) updateCache (GuildMembersChunk GuildMembersChunkData {guildID, members}) =   traverse_ (updateCache . GuildMemberAdd guildID) members updateCache (GuildRoleCreate GuildRoleData {guildID, role}) =@@ -727,10 +726,9 @@     (getID reaction)     ( \m ->         case m ^. #reactions & filter ((== (reaction ^. #emoji)) . (^. #emoji)) of-          [] -> m & #reactions <>~ [Reaction 1 isMe (reaction ^. #emoji)]+          [] -> m & #reactions %~ (<> [Reaction 1 isMe (reaction ^. #emoji)])           _ ->-            m & #reactions . traverse . filtered ((== (reaction ^. #emoji)) . (^. #emoji))-              %~ (#count +~ 1) . (#me ||~ isMe)+            m & #reactions % traversed %~ updateReactionAdd isMe (reaction ^. #emoji)     ) updateCache (MessageReactionRemove reaction) = do   isMe <- (\u -> Just (getID @User reaction) == (getID @User <$> u)) <$> getBotUser@@ -738,14 +736,13 @@     (getID reaction)     ( \m ->         m-          & #reactions . traverse . filtered ((== (reaction ^. #emoji)) . (^. #emoji))-            %~ (#count -~ 1) . (#me &&~ not isMe)+          & #reactions % traversed %~ updateReactionRemove isMe (reaction ^. #emoji)           & #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)+  updateGuild (getID presence) (#presences % at userID ?~ presence) updateCache (UserUpdate user) = setBotUser user -- we don't handle group channels currently updateCache (ChannelCreate (GroupChannel' _)) = pure ()@@ -774,3 +771,19 @@ -- we don't update the cache from interactions -- TODO: should we? updateCache (InteractionCreate _) = pure ()++updateReactionAdd :: Bool -> RawEmoji -> Reaction -> Reaction+updateReactionAdd isMe emoji reaction =+  if emoji == reaction ^. #emoji+    then+      reaction & #count %~ succ+        & #me %~ (|| isMe)+    else reaction++updateReactionRemove :: Bool -> RawEmoji -> Reaction -> Reaction+updateReactionRemove isMe emoji reaction =+  if emoji == reaction ^. #emoji+    then+      reaction & #count %~ pred+        & #me %~ (&& not isMe)+    else reaction

@@ -7,9 +7,9 @@ import Calamity.Internal.Utils import Control.Concurrent.MVar import Control.Concurrent.STM-import Control.Lens import Control.Monad import Data.Traversable+import Optics import Polysemy (Sem) import qualified Polysemy as P import qualified Polysemy.Fail as P

@@ -1,3 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+ -- | Types for the client module Calamity.Client.Types (   Client (..),@@ -49,13 +51,11 @@ import qualified Df1 import qualified Di.Core as DC import GHC.Exts (fromList)-import GHC.Generics+import Optics.TH import qualified Polysemy as P import qualified Polysemy.Async as P import qualified Polysemy.AtomicState as P import qualified Polysemy.Reader as P-import TextShow-import qualified TextShow.Generic as TSG  data Client = Client   { shards :: TVar [(InChan ControlMessage, Async (Maybe ()))]@@ -67,7 +67,6 @@   , ehidCounter :: IORef Integer   , initialDi :: Maybe (DC.Di Df1.Level Df1.Path Df1.Message)   }-  deriving (Generic)  -- | Constraints required by the bot client type BotC r =@@ -177,16 +176,14 @@     GuildCreateNew   | -- | The guild is becoming available     GuildCreateAvailable-  deriving (Generic, Show)-  deriving (TextShow) via TSG.FromGeneric GuildCreateStatus+  deriving (Show)  data GuildDeleteStatus   = -- | The guild became unavailable     GuildDeleteUnavailable   | -- | The bot was removed from the guild     GuildDeleteRemoved-  deriving (Generic, Show)-  deriving (TextShow) via TSG.FromGeneric GuildDeleteStatus+  deriving (Show)  {- | A type family to decide what the parameters for an event handler should be  determined by the type of event it is handling.@@ -384,3 +381,5 @@         unwrapEventHandler @( 'CustomEvt Void) $           fromMaybe mempty (TM.lookup handlers :: Maybe (EventHandler ( 'CustomEvt Void)))    in maybe mempty (map eh . unwrapCustomEHTypeStorage) $ TM.lookup @a handlerMap++$(makeFieldLabelsNoPrefix ''Client)

@@ -12,7 +12,7 @@ import Calamity.Types.Snowflake import CalamityCommands.ParameterInfo import CalamityCommands.Parser-import Control.Lens hiding (Context)+import Optics import Control.Monad import Control.Monad.Trans (lift) import Data.Maybe (fromMaybe, isJust)@@ -80,7 +80,7 @@         ( \mid -> do             ctx <- P.ask             guild <- join <$> getGuild `traverse` ctxGuildID ctx-            pure $ guild ^? _Just . #members . ix mid+            pure $ guild ^? _Just % #members % ix mid         )   parameterDescription = "user mention or id" @@ -110,7 +110,7 @@         ( \cid -> do             ctx <- P.ask             guild <- join <$> getGuild `traverse` ctxGuildID ctx-            pure $ guild ^? _Just . #channels . ix cid+            pure $ guild ^? _Just % #channels % ix cid         )   parameterDescription = "channel mention or id" @@ -140,7 +140,7 @@         ( \eid -> do             ctx <- P.ask             guild <- join <$> getGuild `traverse` ctxGuildID ctx-            pure $ guild ^? _Just . #emojis . ix eid+            pure $ guild ^? _Just % #emojis % ix eid         )   parameterDescription = "emoji or id" @@ -164,7 +164,7 @@         ( \rid -> do             ctx <- P.ask             guild <- join <$> getGuild `traverse` ctxGuildID ctx-            pure $ guild ^? _Just . #roles . ix rid+            pure $ guild ^? _Just % #roles % ix rid         )   parameterDescription = "role mention or id" 

@@ -1,3 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+ -- | Command invokation context module Calamity.Commands.Context (   CalamityCommandContext (..),@@ -17,14 +19,12 @@ import Calamity.Types.Tellable import qualified CalamityCommands.Context as CC import Control.Applicative-import Control.Lens hiding (Context) import Control.Monad import qualified Data.Text as T-import GHC.Generics+import Optics import qualified Polysemy as P import qualified Polysemy.Fail as P-import TextShow-import qualified TextShow.Generic as TSG+import qualified TextShow  class CommandContext c => CalamityCommandContext c where   -- | The id of the channel that invoked this command@@ -61,12 +61,14 @@   , -- | The message remaining after consuming the prefix     unparsedParams :: T.Text   }-  deriving (Show, Generic)-  deriving (TextShow) via TSG.FromGeneric FullContext+  deriving (Show)+  deriving (TextShow.TextShow) via TextShow.FromStringShow FullContext   deriving (HasID Channel) via HasIDField "channel" FullContext   deriving (HasID Message) via HasIDField "message" FullContext   deriving (HasID User) via HasIDField "user" FullContext +$(makeFieldLabelsNoPrefix ''FullContext)+ instance CC.CommandContext IO FullContext () where   ctxPrefix = (^. #prefix)   ctxCommand = (^. #command)@@ -91,8 +93,8 @@ buildContext :: P.Member CacheEff r => Message -> User -> Maybe Member -> T.Text -> Command FullContext -> T.Text -> P.Sem r (Maybe FullContext) buildContext msg usr mem prefix command unparsed = (rightToMaybe <$>) . P.runFail $ do   guild <- join <$> getGuild `traverse` (msg ^. #guildID)-  let member = mem <|> guild ^? _Just . #members . ix (coerceSnowflake $ getID @User msg)-  let gchan = guild ^? _Just . #channels . ix (coerceSnowflake $ getID @Channel msg)+  let member = mem <|> guild ^? _Just % #members % ix (coerceSnowflake $ getID @User msg)+  let gchan = guild ^? _Just % #channels % ix (coerceSnowflake $ getID @Channel msg)   Just channel <- case gchan of     Just chan -> pure . pure $ GuildChannel' chan     Nothing -> DMChannel' <<$>> getDM (coerceSnowflake $ getID @Channel msg)@@ -120,12 +122,14 @@   , -- | The message remaining after consuming the prefix     unparsedParams :: T.Text   }-  deriving (Show, Generic)-  deriving (TextShow) via TSG.FromGeneric LightContext+  deriving (Show)+  deriving (TextShow.TextShow) via TextShow.FromStringShow LightContext   deriving (HasID Channel) via HasIDField "channelID" LightContext   deriving (HasID Message) via HasIDField "message" LightContext   deriving (HasID User) via HasIDField "user" LightContext +$(makeFieldLabelsNoPrefix ''LightContext)+ instance CC.CommandContext IO LightContext () where   ctxPrefix = (^. #prefix)   ctxCommand = (^. #command)@@ -134,7 +138,7 @@ instance CalamityCommandContext LightContext where   ctxChannelID = (^. #channelID)   ctxGuildID = (^. #guildID)-  ctxUserID = (^. #user . #id)+  ctxUserID = (^. #user % #id)   ctxMessage = (^. #message)  instance Tellable LightContext where

@@ -144,7 +144,7 @@  @  'Calamity.Commands.Dsl.command' \@\'['CalamityCommands.Parser.Named' "user" ('Calamity.Types.Snowflake' 'Calamity.Types.Model.User'),                 'CalamityCommands.Parser.Named' "reason" ('CalamityCommands.Parser.KleeneStarConcat' 'T.Text')]-    "ban" $ \\ctx uid r -> case (ctx 'Control.Lens.^.' #guild) of+    "ban" $ \\ctx uid r -> case (ctx 'Optics.^.' #guild) of       'Just' guild -> do         'Control.Monad.void' . 'Calamity.HTTP.invoke' $ 'Calamity.HTTP.Guild.CreateGuildBan' guild uid ('Calamity.HTTP.Guild.CreateGuildBanData' 'Nothing' $ 'Just' r)         'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' ctx ("Banned user `" '<>' 'TextShow.showt' uid '<>' "` with reason: " '<>' r)@@ -178,7 +178,7 @@  @  'commandA' \@\'['CalamityCommands.Parser.Named' "user" ('Calamity.Types.Snowflake' 'Calamity.Types.Model.User'),                 'CalamityCommands.Parser.Named' "reason" ('CalamityCommands.Parser.KleeneStarConcat' 'T.Text')]-    "ban" [] $ \\ctx uid r -> case (ctx 'Control.Lens.^.' #guild) of+    "ban" [] $ \\ctx uid r -> case (ctx 'Optics.^.' #guild) of       'Just' guild -> do         'Control.Monad.void' . 'Calamity.HTTP.invoke' $ 'Calamity.HTTP.Guild.CreateGuildBan' guild uid ('Calamity.HTTP.Guild.CreateGuildBanData' 'Nothing' $ 'Just' r)         'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' ctx ("Banned user `" '<>' 'TextShow.showt' uid '<>' "` with reason: " '<>' r)

@@ -1,5 +1,4 @@-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE TemplateHaskell #-}  -- | Command handler utilities module Calamity.Commands.Utils (@@ -27,8 +26,8 @@ import Control.Monad import qualified Data.Text as T import Data.Typeable-import GHC.Generics (Generic) import qualified Polysemy as P+import Optics.TH (makeFieldLabelsNoPrefix)  data CmdInvokeFailReason c   = NoContext@@ -39,7 +38,7 @@   { ctx :: c   , err :: CC.CommandError   }-  deriving (Show, Generic)+  deriving (Show)  data CommandNotFound = CommandNotFound   { msg :: Message@@ -48,12 +47,12 @@   , -- | The groups that were successfully parsed     path :: [T.Text]   }-  deriving (Show, Generic)+  deriving (Show)  newtype CommandInvoked c = CommandInvoked   { ctx :: c   }-  deriving stock (Show, Generic)+  deriving stock (Show)  -- | A default interpretation for 'CC.ParsePrefix' that uses a single constant prefix. useConstantPrefix :: T.Text -> P.Sem (CC.ParsePrefix Message ': r) a -> P.Sem r a@@ -114,3 +113,8 @@         Nothing -> pure ()     _ -> pure ()   pure (remove, handler, res)++$(makeFieldLabelsNoPrefix ''CmdInvokeFailReason)+$(makeFieldLabelsNoPrefix ''CtxCommandError)+$(makeFieldLabelsNoPrefix ''CommandNotFound)+$(makeFieldLabelsNoPrefix ''CommandInvoked)

@@ -1,7 +1,8 @@+{-# LANGUAGE TemplateHaskell #-}+ -- | module containing all dispatch events module Calamity.Gateway.DispatchEvents where -import Calamity.Internal.AesonThings import Calamity.Internal.ConstructorName import Calamity.Internal.UnixTimestamp import Calamity.Internal.Utils@@ -18,227 +19,326 @@ import Calamity.Types.Model.User import Calamity.Types.Model.Voice import Calamity.Types.Snowflake-import Data.Aeson+import Data.Aeson ((.:), (.:?))+import qualified Data.Aeson as Aeson import Data.Kind (Type) import Data.Text (Text) import Data.Time import Data.Typeable (Typeable) import GHC.Generics+import Optics.TH  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 !(Snowflake Guild) !Member-    | GuildMemberRemove !GuildMemberRemoveData-    | GuildMemberUpdate !GuildMemberUpdateData-    | GuildMembersChunk !GuildMembersChunkData-    | GuildRoleCreate !GuildRoleData-    | GuildRoleUpdate !GuildRoleData-    | GuildRoleDelete !GuildRoleDeleteData-    | InviteCreate !InviteCreateData-    | InviteDelete !InviteDeleteData-    | MessageCreate !Message !(Maybe User) !(Maybe Member)-    | MessageUpdate !UpdatedMessage !(Maybe User) !(Maybe Member)-    | 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)+  = 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 !(Snowflake Guild) !Member+  | GuildMemberRemove !GuildMemberRemoveData+  | GuildMemberUpdate !GuildMemberUpdateData+  | GuildMembersChunk !GuildMembersChunkData+  | GuildRoleCreate !GuildRoleData+  | GuildRoleUpdate !GuildRoleData+  | GuildRoleDelete !GuildRoleDeleteData+  | InviteCreate !InviteCreateData+  | InviteDelete !InviteDeleteData+  | MessageCreate !Message !(Maybe User) !(Maybe Member)+  | MessageUpdate !UpdatedMessage !(Maybe User) !(Maybe Member)+  | 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) +instance Aeson.FromJSON ReadyData where+  parseJSON = Aeson.withObject "ReadyData" $ \v ->+    ReadyData+      <$> v .: "v"+      <*> v .: "user"+      <*> v .: "guilds"+      <*> v .: "session_id"+ 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) +instance Aeson.FromJSON ChannelPinsUpdateData where+  parseJSON = Aeson.withObject "ChannelPinsUpdateData" $ \v ->+    ChannelPinsUpdateData+      <$> v .: "channel_id"+      <*> v .: "last_pin_timestamp"+ data GuildEmojisUpdateData = GuildEmojisUpdateData-    { guildID :: Snowflake Guild-    , emojis :: [Emoji]-    }-    deriving (Show, Generic)-    deriving (FromJSON) via CalamityJSON GuildEmojisUpdateData+  { guildID :: Snowflake Guild+  , emojis :: [Emoji]+  }+  deriving (Show) +instance Aeson.FromJSON GuildEmojisUpdateData where+  parseJSON = Aeson.withObject "GuildEmojisUpdateData" $ \v ->+    GuildEmojisUpdateData+      <$> v .: "guild_id"+      <*> v .: "emojis"+ newtype GuildIntegrationsUpdateData = GuildIntegrationsUpdateData-    { guildID :: Snowflake Guild-    }-    deriving newtype (Show, Generic)-    deriving (FromJSON) via CalamityJSON GuildIntegrationsUpdateData+  { guildID :: Snowflake Guild+  }+  deriving stock (Show) +instance Aeson.FromJSON GuildIntegrationsUpdateData where+  parseJSON = Aeson.withObject "GuildIntegrationsUpdateData" $ \v ->+    GuildIntegrationsUpdateData+      <$> v .: "guild_id"+ data GuildMemberRemoveData = GuildMemberRemoveData-    { guildID :: Snowflake Guild-    , user :: User-    }-    deriving (Show, Generic)-    deriving (FromJSON) via CalamityJSON GuildMemberRemoveData+  { guildID :: Snowflake Guild+  , user :: User+  }+  deriving (Show) +instance Aeson.FromJSON GuildMemberRemoveData where+  parseJSON = Aeson.withObject "GuildMemberRemoveData" $ \v ->+    GuildMemberRemoveData+      <$> v .: "guild_id"+      <*> v .: "user"+ 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) +instance Aeson.FromJSON GuildMemberUpdateData where+  parseJSON = Aeson.withObject "GuildMemberUpdateData" $ \v ->+    GuildMemberUpdateData+      <$> v .: "guild_id"+      <*> v .: "roles"+      <*> v .: "user"+      <*> v .:? "nick"+ data GuildMembersChunkData = GuildMembersChunkData-    { guildID :: Snowflake Guild-    , members :: [Member]-    }-    deriving (Show, Generic)+  { guildID :: Snowflake Guild+  , members :: [Member]+  }+  deriving (Show) -instance FromJSON GuildMembersChunkData where-    parseJSON = withObject "GuildMembersChunkData" $ \v -> do-        guildID <- v .: "guild_id"+instance Aeson.FromJSON GuildMembersChunkData where+  parseJSON = Aeson.withObject "GuildMembersChunkData" $ \v -> do+    guildID <- v Aeson..: "guild_id" -        members' <- do-            members' <- v .: "members"-            traverse (parseJSON . Object) members'+    members' <- do+      members' <- v Aeson..: "members"+      traverse (Aeson.parseJSON . Aeson.Object) 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) +instance Aeson.FromJSON GuildRoleData where+  parseJSON = Aeson.withObject "GuildRoleData" $ \v ->+    GuildRoleData+      <$> v .: "guild_id"+      <*> v .: "role"+ 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)+instance Aeson.FromJSON GuildRoleDeleteData where+  parseJSON = Aeson.withObject "GuildRoleDeleteData" $ \v ->+    GuildRoleDeleteData+      <$> v .: "guild_id"+      <*> v .: "role_id"  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) +instance Aeson.FromJSON InviteCreateData where+  parseJSON = Aeson.withObject "InviteCreateData" $ \v -> do+    let inviter = (v .:? "inviter") >>= traverse (.: "id")+        targetUser = (v .:? "target_user") >>= traverse (.: "id")++    InviteCreateData+      <$> v .: "channel_id"+      <*> v .: "code"+      <*> v .: "created_at"+      <*> v .:? "guild_id"+      <*> inviter+      <*> v .: "max_age"+      <*> v .: "max_uses"+      <*> targetUser+      <*> v .:? "target_user_type"+      <*> v .: "temporary"+      <*> v .: "uses"+ 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) +instance Aeson.FromJSON InviteDeleteData where+  parseJSON = Aeson.withObject "InviteDeleteData" $ \v ->+    InviteDeleteData+      <$> v .: "channel_id"+      <*> v .:? "guild_id"+      <*> v .: "code"+ 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) +instance Aeson.FromJSON MessageDeleteData where+  parseJSON = Aeson.withObject "MessageDeleteData" $ \v ->+    MessageDeleteData+      <$> v .: "id"+      <*> v .: "channel_id"+      <*> v .: "guild_id"+ 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) +instance Aeson.FromJSON MessageDeleteBulkData where+  parseJSON = Aeson.withObject "MessageDeleteBulkData" $ \v ->+    MessageDeleteBulkData+      <$> v .: "guild_id"+      <*> v .: "channel_id"+      <*> v .: "ids"+ 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) +instance Aeson.FromJSON MessageReactionRemoveAllData where+  parseJSON = Aeson.withObject "MessageReactionRemoveAllData" $ \v ->+    MessageReactionRemoveAllData+      <$> v .: "channel_id"+      <*> v .: "message_id"+      <*> v .: "guild_id"+ data PresenceUpdateData = PresenceUpdateData-    { userID :: Snowflake User-    , presence :: Presence-    }-    deriving (Show, Generic)+  { userID :: Snowflake User+  , presence :: Presence+  }+  deriving (Show) -instance FromJSON PresenceUpdateData where-    parseJSON = withObject "PresenceUpdate" $ \v -> do-        user <- (v .: "user") >>= (.: "id")-        presence <- parseJSON $ Object v-        pure $ PresenceUpdateData user presence+instance Aeson.FromJSON PresenceUpdateData where+  parseJSON = Aeson.withObject "PresenceUpdate" $ \v -> do+    user <- (v Aeson..: "user") >>= (Aeson..: "id")+    presence <- Aeson.parseJSON $ Aeson.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) -newtype VoiceServerUpdateData = VoiceServerUpdateData Value-    deriving newtype (Show, Generic)-    deriving newtype (ToJSON, FromJSON)+instance Aeson.FromJSON TypingStartData where+  parseJSON = Aeson.withObject "TypingStartData" $ \v ->+    TypingStartData+      <$> v .: "channel_id"+      <*> v .: "guild_id"+      <*> v .: "user_id"+      <*> v .: "timestamp" -newtype WebhooksUpdateData = WebhooksUpdateData Value-    deriving newtype (Show, Generic)-    deriving newtype (ToJSON, FromJSON)+newtype VoiceServerUpdateData = VoiceServerUpdateData Aeson.Value+  deriving stock (Show)+  deriving newtype (Aeson.ToJSON, Aeson.FromJSON) +newtype WebhooksUpdateData = WebhooksUpdateData Aeson.Value+  deriving stock (Show)+  deriving newtype (Aeson.ToJSON, Aeson.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)+  deriving (HasID User) via HasIDField "userID" ReactionEvtData+  deriving (HasID Channel) via HasIDField "channelID" ReactionEvtData+  deriving (HasID Message) via HasIDField "messageID" ReactionEvtData++instance Aeson.FromJSON ReactionEvtData where+  parseJSON = Aeson.withObject "ReactionEvtData" $ \v ->+    ReactionEvtData+      <$> v .: "user_id"+      <*> v .: "channel_id"+      <*> v .: "message_id"+      <*> v .: "guild_id"+      <*> v .: "emoji"++$(makeFieldLabelsNoPrefix ''ReadyData)+$(makeFieldLabelsNoPrefix ''ReactionEvtData)

@@ -7,32 +7,88 @@   newShard, ) where -import Calamity.Gateway.DispatchEvents-import Calamity.Gateway.Intents-import Calamity.Gateway.Types-import Calamity.Internal.RunIntoIO-import Calamity.Internal.Utils-import Calamity.Metrics.Eff-import Calamity.Types.LogEff-import Calamity.Types.Token-import Control.Concurrent-import Control.Concurrent.Async+import Calamity.Gateway.DispatchEvents (+  CalamityEvent (Dispatch),+  DispatchData (Ready),+ )+import Calamity.Gateway.Intents (Intents)+import Calamity.Gateway.Types (+  ControlMessage (..),+  IdentifyData (+    IdentifyData,+    compress,+    intents,+    largeThreshold,+    presence,+    properties,+    shard,+    token+  ),+  IdentifyProps (IdentifyProps, browser, device),+  ReceivedDiscordMessage (+    EvtDispatch,+    HeartBeatAck,+    HeartBeatReq,+    Hello,+    InvalidSession,+    Reconnect+  ),+  ResumeData (ResumeData, seq, sessionID, token),+  SentDiscordMessage (HeartBeat, Identify, Resume, StatusUpdate),+  Shard (..),+  ShardC,+  ShardFlowControl (..),+  ShardMsg (..),+  ShardState (ShardState, wsConn),+  StatusUpdateData,+ )+import Calamity.Internal.RunIntoIO (bindSemToIO)+import Calamity.Internal.Utils (+  debug,+  error,+  info,+  leftToMaybe,+  swap,+  unlessM,+  untilJustFinalIO,+  whenJust,+  whileMFinalIO,+ )+import Calamity.Metrics.Eff (+  MetricEff,+  modifyGauge,+  registerGauge,+ )+import Calamity.Types.LogEff (LogEff)+import Calamity.Types.Token (Token, rawToken)+import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (Async, cancel) import qualified Control.Concurrent.Chan.Unagi as UC-import Control.Concurrent.STM-import Control.Concurrent.STM.TBMQueue-import Control.Exception+import Control.Concurrent.STM (STM, atomically, retry)+import Control.Concurrent.STM.TBMQueue (+  TBMQueue,+  closeTBMQueue,+  newTBMQueueIO,+  readTBMQueue,+  tryWriteTBMQueue,+  writeTBMQueue,+ )+import Control.Exception (+  Exception (fromException),+  SomeException,+ ) import qualified Control.Exception.Safe as Ex-import Control.Lens-import Control.Monad-import Control.Monad.State.Lazy+import Optics+import Optics.State.Operators+import Control.Monad (void, when)+import Control.Monad.State.Lazy (runState) import qualified Data.Aeson as A import qualified Data.ByteString.Lazy as LBS import Data.Default.Class (def)-import Data.Functor-import Data.IORef-import Data.Maybe+import Data.IORef (newIORef)+import Data.Maybe (fromMaybe) import qualified Data.Text as T-import DiPolysemy hiding (debug, error, info)+import DiPolysemy (attr, push) import qualified Network.Connection as NC import qualified Network.TLS as NT import qualified Network.TLS.Extra as NT@@ -51,7 +107,7 @@ import qualified Polysemy.AtomicState as P import qualified Polysemy.Error as P import qualified Polysemy.Resource as P-import PyF+import PyF (fmt) import qualified System.X509 as X509 import TextShow (showt) import Prelude hiding (error)@@ -78,7 +134,7 @@     certStore <- X509.getSystemCertificateStore     let clientParams =           (NT.defaultParamsClient (T.unpack host) "443")-            { NT.clientSupported = def{NT.supportedCiphers = NT.ciphersuite_default}+            { NT.clientSupported = def {NT.supportedCiphers = NT.ciphersuite_default}             , NT.clientShared =                 def                   { NT.sharedCAStore = certStore@@ -156,169 +212,167 @@   void outerloop   void $ modifyGauge (subtract 1) activeShards   debug "Shard shut down"- where-  controlStream :: Shard -> TBMQueue ShardMsg -> IO ()-  controlStream shard outqueue = inner-   where-    q = shard ^. #cmdOut-    inner = do-      v <- UC.readChan q-      r <- atomically $ tryWriteTBMQueue' outqueue (Control v)-      when r inner+  where+    controlStream :: Shard -> TBMQueue ShardMsg -> IO ()+    controlStream shard outqueue = inner+      where+        q = shard ^. #cmdOut+        inner = do+          v <- UC.readChan q+          r <- atomically $ tryWriteTBMQueue' outqueue (Control v)+          when r inner -  handleWSException :: SomeException -> IO (Either (ControlMessage, Maybe T.Text) a)-  handleWSException e = pure $ case fromException e of-    Just (CloseRequest code _)-      | code `elem` [4004, 4010, 4011, 4012, 4013, 4014] ->-        Left (ShutDownShard, Just . showt $ code)-    e -> Left (RestartShard, Just . T.pack . show $ e)+    handleWSException :: SomeException -> IO (Either (ControlMessage, Maybe T.Text) a)+    handleWSException e = pure $ case fromException e of+      Just (CloseRequest code _)+        | code `elem` [4004, 4010, 4011, 4012, 4013, 4014] ->+          Left (ShutDownShard, Just . showt $ code)+      e -> Left (RestartShard, Just . T.pack . show $ e) -  discordStream :: P.Members '[LogEff, MetricEff, P.Embed IO, P.Final IO] r => Connection -> TBMQueue ShardMsg -> Sem r ()-  discordStream ws outqueue = inner-   where-    inner = do-      msg <- P.embed $ Ex.catchAny (Right <$> receiveData ws) handleWSException+    discordStream :: P.Members '[LogEff, MetricEff, P.Embed IO, P.Final IO] r => Connection -> TBMQueue ShardMsg -> Sem r ()+    discordStream ws outqueue = inner+      where+        inner = do+          msg <- P.embed $ Ex.catchAny (Right <$> receiveData ws) handleWSException -      case msg of-        Left (c, reason) -> do-          whenJust reason (\r -> error [fmt|Shard closed with reason: {r}|])-          P.embed . atomically $ writeTBMQueue outqueue (Control c)-        Right msg' -> do-          -- debug [fmt|Got msg: {msg'}|]-          let decoded = A.eitherDecode msg'-          r <- case decoded of-            Right a ->-              P.embed . atomically $ tryWriteTBMQueue' outqueue (Discord a)-            Left e -> do-              error [fmt|Failed to decode: {e}|]-              pure True-          when r inner-  outerloop :: ShardC r => Sem r ()-  outerloop = whileMFinalIO $ do-    shard :: Shard <- P.atomicGets (^. #shardS)-    let host = shard ^. #gateway-    let host' = fromMaybe host $ T.stripPrefix "wss://" host-    info [fmt|starting up shard {shardID shard} of {shardCount shard}|]+          case msg of+            Left (c, reason) -> do+              whenJust reason (\r -> error [fmt|Shard closed with reason: {r}|])+              P.embed . atomically $ writeTBMQueue outqueue (Control c)+            Right msg' -> do+              -- debug [fmt|Got msg: {msg'}|]+              let decoded = A.eitherDecode msg'+              r <- case decoded of+                Right a ->+                  P.embed . atomically $ tryWriteTBMQueue' outqueue (Discord a)+                Left e -> do+                  error [fmt|Failed to decode {e}: {msg'}|]+                  pure True+              when r inner+    outerloop :: ShardC r => Sem r ()+    outerloop = whileMFinalIO $ do+      shard :: Shard <- P.atomicGets (^. #shardS)+      let host = shard ^. #gateway+      let host' = fromMaybe host $ T.stripPrefix "wss://" host+      info [fmt|starting up shard {shardID shard} of {shardCount shard}|] -    innerLoopVal <- runWebsocket host' "/?v=9&encoding=json" innerloop+      innerLoopVal <- runWebsocket host' "/?v=9&encoding=json" innerloop -    case innerLoopVal of-      Just ShardFlowShutDown -> do-        info "Shutting down shard"-        pure False-      Just ShardFlowRestart -> do-        info "Restaring shard"-        pure True-      -- we restart normally when we loop+      case innerLoopVal of+        Just ShardFlowShutDown -> do+          info "Shutting down shard"+          pure False+        Just ShardFlowRestart -> do+          info "Restaring shard"+          pure True+        -- we restart normally when we loop -      Nothing -> do-        -- won't happen unless innerloop starts using a non-deterministic effect or connecting to the ws dies-        info "Restarting shard (abnormal reasons?)"-        pure True+        Nothing -> do+          -- won't happen unless innerloop starts using a non-deterministic effect or connecting to the ws dies+          info "Restarting shard (abnormal reasons?)"+          pure True -  innerloop :: ShardC r => Connection -> Sem r ShardFlowControl-  innerloop ws = do-    debug "Entering inner loop of shard"+    innerloop :: ShardC r => Connection -> Sem r ShardFlowControl+    innerloop ws = do+      debug "Entering inner loop of shard" -    shard <- P.atomicGets (^. #shardS)-    P.atomicModify' (#wsConn ?~ ws)+      shard <- P.atomicGets (^. #shardS)+      P.atomicModify' (#wsConn ?~ ws) -    seqNum' <- P.atomicGets (^. #seqNum)-    sessionID' <- P.atomicGets (^. #sessionID)+      seqNum' <- P.atomicGets (^. #seqNum)+      sessionID' <- P.atomicGets (^. #sessionID) -    case (seqNum', sessionID') of-      (Just n, Just s) -> do-        debug [fmt|Resuming shard (sessionID: {s}, seq: {n})|]-        sendToWs-          ( Resume-              ResumeData-                { token = shard ^. #token-                , sessionID = s-                , seq = n-                }-          )-      _noActiveSession -> do-        debug "Identifying shard"-        sendToWs-          ( Identify-              IdentifyData-                { token = shard ^. #token-                , properties =-                    IdentifyProps-                      { browser = "Calamity: https://github.com/simmsb/calamity"-                      , device = "Calamity: https://github.com/simmsb/calamity"-                      }-                , compress = False-                , largeThreshold = 250-                , shard =-                    ( shard ^. #shardID-                    , shard ^. #shardCount-                    )-                , presence = shard ^. #initialStatus-                , intents = shard ^. #intents-                }-          )+      case (seqNum', sessionID') of+        (Just n, Just s) -> do+          debug [fmt|Resuming shard (sessionID: {s}, seq: {n})|]+          sendToWs+            ( Resume+                ResumeData+                  { token = shard ^. #token+                  , sessionID = s+                  , seq = n+                  }+            )+        _noActiveSession -> do+          debug "Identifying shard"+          sendToWs+            ( Identify+                IdentifyData+                  { token = shard ^. #token+                  , properties =+                      IdentifyProps+                        { browser = "Calamity: https://github.com/simmsb/calamity"+                        , device = "Calamity: https://github.com/simmsb/calamity"+                        }+                  , compress = False+                  , largeThreshold = Nothing+                  , shard =+                      Just ( shard ^. #shardID , shard ^. #shardCount )+                  , presence = shard ^. #initialStatus+                  , intents = shard ^. #intents+                  }+            ) -    result <--      P.resourceToIOFinal $-        P.bracket-          (P.embed $ newTBMQueueIO 1)-          (P.embed . atomically . closeTBMQueue)-          ( \q -> do-              debug "handling events now"-              _controlThread <- P.async . P.embed $ controlStream shard q-              _discordThread <- P.async $ discordStream ws q-              P.raise . untilJustFinalIO . (leftToMaybe <$>) . P.runError $ do-                -- only we close the queue-                msg <- P.embed . atomically $ readTBMQueue q-                handleMsg =<< restartUnless "shard message stream closed by someone other than the sink" msg-          )+      result <-+        P.resourceToIOFinal $+          P.bracket+            (P.embed $ newTBMQueueIO 1)+            (P.embed . atomically . closeTBMQueue)+            ( \q -> do+                debug "handling events now"+                _controlThread <- P.async . P.embed $ controlStream shard q+                _discordThread <- P.async $ discordStream ws q+                P.raise . untilJustFinalIO . (leftToMaybe <$>) . P.runError $ do+                  -- only we close the queue+                  msg <- P.embed . atomically $ readTBMQueue q+                  handleMsg =<< restartUnless "shard message stream closed by someone other than the sink" msg+            ) -    debug "Exiting inner loop of shard"+      debug "Exiting inner loop of shard" -    P.atomicModify' (#wsConn .~ Nothing)-    haltHeartBeat-    pure result-  handleMsg :: (ShardC r, P.Member (P.Error ShardFlowControl) r) => ShardMsg -> Sem r ()-  handleMsg (Discord msg) = case msg of-    EvtDispatch sn data' -> do-      -- trace $ "Handling event: ("+||data'||+")"-      P.atomicModify' (#seqNum ?~ sn)+      P.atomicModify' (#wsConn .~ Nothing)+      haltHeartBeat+      pure result+    handleMsg :: (ShardC r, P.Member (P.Error ShardFlowControl) r) => ShardMsg -> Sem r ()+    handleMsg (Discord msg) = case msg of+      EvtDispatch sn data' -> do+        -- trace $ "Handling event: ("+||data'||+")"+        P.atomicModify' (#seqNum ?~ sn) -      case data' of-        Ready rdata' ->-          P.atomicModify' (#sessionID ?~ (rdata' ^. #sessionID))-        _NotReady -> pure ()+        case data' of+          Ready rdata' ->+            P.atomicModify' (#sessionID ?~ (rdata' ^. #sessionID))+          _NotReady -> pure () -      shard <- P.atomicGets (^. #shardS)-      P.embed $ UC.writeChan (shard ^. #evtIn) (Dispatch (shard ^. #shardID) data')-    HeartBeatReq -> do-      debug "Received heartbeat request"-      sendHeartBeat-    Reconnect -> do-      debug "Being asked to restart by Discord"-      P.throw ShardFlowRestart-    InvalidSession resumable -> do-      if resumable-        then info "Received resumable invalid session"-        else do-          info "Received non-resumable invalid session, sleeping for 15 seconds then retrying"-          P.atomicModify' (#sessionID .~ Nothing)-          P.atomicModify' (#seqNum .~ Nothing)-          P.embed $ threadDelay (15 * 1000 * 1000)-      P.throw ShardFlowRestart-    Hello interval -> do-      info [fmt|Received hello, beginning to heartbeat at an interval of {interval}ms|]-      startHeartBeatLoop interval-    HeartBeatAck -> do-      debug "Received heartbeat ack"-      P.atomicModify' (#hbResponse .~ True)-  handleMsg (Control msg) = case msg of-    SendPresence data' -> do-      debug [fmt|Sending presence: ({data':s})|]-      sendToWs $ StatusUpdate data'-    RestartShard -> P.throw ShardFlowRestart-    ShutDownShard -> P.throw ShardFlowShutDown+        shard <- P.atomicGets (^. #shardS)+        P.embed $ UC.writeChan (shard ^. #evtIn) (Dispatch (shard ^. #shardID) data')+      HeartBeatReq -> do+        debug "Received heartbeat request"+        sendHeartBeat+      Reconnect -> do+        debug "Being asked to restart by Discord"+        P.throw ShardFlowRestart+      InvalidSession resumable -> do+        if resumable+          then info "Received resumable invalid session"+          else do+            info "Received non-resumable invalid session, sleeping for 15 seconds then retrying"+            P.atomicModify' (#sessionID .~ Nothing)+            P.atomicModify' (#seqNum .~ Nothing)+            P.embed $ threadDelay (15 * 1000 * 1000)+        P.throw ShardFlowRestart+      Hello interval -> do+        info [fmt|Received hello, beginning to heartbeat at an interval of {interval}ms|]+        startHeartBeatLoop interval+      HeartBeatAck -> do+        debug "Received heartbeat ack"+        P.atomicModify' (#hbResponse .~ True)+    handleMsg (Control msg) = case msg of+      SendPresence data' -> do+        debug [fmt|Sending presence: ({data':s})|]+        sendToWs $ StatusUpdate data'+      RestartShard -> P.throw ShardFlowRestart+      ShutDownShard -> P.throw ShardFlowShutDown  startHeartBeatLoop :: ShardC r => Int -> Sem r () startHeartBeatLoop interval = do

@@ -1,61 +1,63 @@--- | Types for shards-module Calamity.Gateway.Types-    ( ShardC-    , ShardMsg(..)-    , ReceivedDiscordMessage(..)-    , SentDiscordMessage(..)-    , DispatchType(..)-    , IdentifyData(..)-    , StatusUpdateData(..)-    , ResumeData(..)-    , RequestGuildMembersData(..)-    , IdentifyProps(..)-    , ControlMessage(..)-    , ShardFlowControl(..)-    , Shard(..)-    , ShardState(..) ) where--import           Calamity.Gateway.DispatchEvents-import           Calamity.Gateway.Intents-import           Calamity.Internal.AesonThings-import           Calamity.Metrics.Eff-import           Calamity.Types.LogEff-import           Calamity.Types.Model.Guild.Guild-import           Calamity.Types.Model.Voice-import           Calamity.Types.Model.Presence.Activity-import           Calamity.Types.Model.User (StatusType)-import           Calamity.Types.Snowflake--import           Control.Concurrent.Async-import           Control.Concurrent.Chan.Unagi--import           Data.Aeson-import qualified Data.Aeson.Types                 as AT-import           Data.Generics.Labels             ()-import           Data.Maybe-import           Data.Text                   ( Text )--import           GHC.Generics+{-# LANGUAGE TemplateHaskell #-} -import           Network.WebSockets.Connection    ( Connection )+-- | Types for shards+module Calamity.Gateway.Types (+  ShardC,+  ShardMsg (..),+  ReceivedDiscordMessage (..),+  SentDiscordMessage (..),+  DispatchType (..),+  IdentifyData (..),+  StatusUpdateData (..),+  ResumeData (..),+  RequestGuildMembersData (..),+  IdentifyProps (..),+  ControlMessage (..),+  ShardFlowControl (..),+  Shard (..),+  ShardState (..),+) where -import qualified Polysemy                         as P-import qualified Polysemy.Async                   as P-import qualified Polysemy.AtomicState             as P-import qualified TextShow.Generic as TSG-import TextShow (TextShow)-import Control.Lens.Operators ((^?))+import Calamity.Gateway.DispatchEvents+import Calamity.Gateway.Intents+import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=))+import Calamity.Metrics.Eff+import Calamity.Types.LogEff+import Calamity.Types.Model.Guild.Guild+import Calamity.Types.Model.Presence.Activity+import Calamity.Types.Model.User+import Calamity.Types.Model.Voice+import Calamity.Types.Snowflake+import Control.Concurrent.Async+import Control.Concurrent.Chan.Unagi+import qualified Data.Aeson as Aeson+import Data.Aeson.Optics import Data.Aeson.Types (parseMaybe)-import Control.Lens (Ixed(ix))-import Data.Aeson.Lens+import qualified Data.Aeson.Types as AT+import Data.Text (Text)+import GHC.Generics+import Network.WebSockets.Connection (Connection)+import Optics+import qualified Polysemy as P+import qualified Polysemy.Async as P+import qualified Polysemy.AtomicState as P -type ShardC r = (P.Members '[LogEff, P.AtomicState ShardState, P.Embed IO, P.Final IO,-  P.Async, MetricEff] r)+type ShardC r =+  ( P.Members+      '[ LogEff+       , P.AtomicState ShardState+       , P.Embed IO+       , P.Final IO+       , P.Async+       , MetricEff+       ]+      r+  )  data ShardMsg   = Discord ReceivedDiscordMessage   | Control ControlMessage-  deriving ( Show, Generic )+  deriving (Show)  data ReceivedDiscordMessage   = EvtDispatch Int !DispatchData@@ -64,86 +66,89 @@   | InvalidSession Bool   | Hello Int   | HeartBeatAck-  deriving ( Show, Generic )+  deriving (Show) -instance FromJSON ReceivedDiscordMessage where-  parseJSON = withObject "ReceivedDiscordMessage" $ \v -> do-    op :: Int <- v .: "op"+instance Aeson.FromJSON ReceivedDiscordMessage where+  parseJSON = Aeson.withObject "ReceivedDiscordMessage" $ \v -> do+    op :: Int <- v Aeson..: "op"     case op of-      0  -> do-        d <- v .: "d"-        t <- v .: "t"-        s <- v .: "s"+      0 -> do+        d <- v Aeson..: "d"+        t <- v Aeson..: "t"+        s <- v Aeson..: "s"         EvtDispatch s <$> parseDispatchData t d--      1  -> pure HeartBeatReq--      7  -> pure Reconnect--      9  -> InvalidSession <$> v .: "d"--      10 -> Hello <$> do-        d <- v .: "d"-        d .: "heartbeat_interval"-+      1 -> pure HeartBeatReq+      7 -> pure Reconnect+      9 -> InvalidSession <$> v Aeson..: "d"+      10 ->+        Hello <$> do+          d <- v Aeson..: "d"+          d Aeson..: "heartbeat_interval"       11 -> pure HeartBeatAck--      _  -> fail $ "invalid opcode: " <> show op+      _ -> fail $ "invalid opcode: " <> show op -parseDispatchData :: DispatchType -> Value -> AT.Parser DispatchData-parseDispatchData READY data'                       = Ready <$> parseJSON data'-parseDispatchData RESUMED _                         = pure Resumed-parseDispatchData CHANNEL_CREATE data'              = ChannelCreate <$> parseJSON data'-parseDispatchData CHANNEL_UPDATE data'              = ChannelUpdate <$> parseJSON data'-parseDispatchData CHANNEL_DELETE data'              = ChannelDelete <$> parseJSON data'-parseDispatchData CHANNEL_PINS_UPDATE data'         = ChannelPinsUpdate <$> parseJSON data'-parseDispatchData GUILD_CREATE data'                = GuildCreate <$> parseJSON data'-parseDispatchData GUILD_UPDATE data'                = GuildUpdate <$> parseJSON data'-parseDispatchData GUILD_DELETE data'                = GuildDelete <$> parseJSON data'-parseDispatchData GUILD_BAN_ADD data'               = GuildBanAdd <$> parseJSON data'-parseDispatchData GUILD_BAN_REMOVE data'            = GuildBanRemove <$> parseJSON data'-parseDispatchData GUILD_EMOJIS_UPDATE data'         = GuildEmojisUpdate <$> parseJSON data'-parseDispatchData GUILD_INTEGRATIONS_UPDATE data'   = GuildIntegrationsUpdate <$> parseJSON data'-parseDispatchData GUILD_MEMBER_ADD data'            = do-  guildID <- withObject "GuildMemberAdd.guild_id" (.: "guild_id") data'-  GuildMemberAdd guildID <$> parseJSON data'-parseDispatchData GUILD_MEMBER_REMOVE data'         = GuildMemberRemove <$> parseJSON data'-parseDispatchData GUILD_MEMBER_UPDATE data'         = GuildMemberUpdate <$> parseJSON data'-parseDispatchData GUILD_MEMBERS_CHUNK data'         = GuildMembersChunk <$> parseJSON data'-parseDispatchData GUILD_ROLE_CREATE data'           = GuildRoleCreate <$> parseJSON data'-parseDispatchData GUILD_ROLE_UPDATE data'           = GuildRoleUpdate <$> parseJSON data'-parseDispatchData GUILD_ROLE_DELETE data'           = GuildRoleDelete <$> parseJSON data'-parseDispatchData INVITE_CREATE data'               = InviteCreate <$> parseJSON data'-parseDispatchData INVITE_DELETE data'               = InviteDelete <$> parseJSON data'-parseDispatchData MESSAGE_CREATE data'              = do-  message <- parseJSON data'-  let member = parseMaybe (withObject "MessageCreate.member" $ \o -> do-                                         userObject :: Object <- o .: "author"-                                         memberObject :: Object <- o .: "member"-                                         parseJSON $ Object (memberObject <> "user" .= userObject)) data'+parseDispatchData :: DispatchType -> Aeson.Value -> AT.Parser DispatchData+parseDispatchData READY data' = Ready <$> Aeson.parseJSON data'+parseDispatchData RESUMED _ = pure Resumed+parseDispatchData CHANNEL_CREATE data' = ChannelCreate <$> Aeson.parseJSON data'+parseDispatchData CHANNEL_UPDATE data' = ChannelUpdate <$> Aeson.parseJSON data'+parseDispatchData CHANNEL_DELETE data' = ChannelDelete <$> Aeson.parseJSON data'+parseDispatchData CHANNEL_PINS_UPDATE data' = ChannelPinsUpdate <$> Aeson.parseJSON data'+parseDispatchData GUILD_CREATE data' = GuildCreate <$> Aeson.parseJSON data'+parseDispatchData GUILD_UPDATE data' = GuildUpdate <$> Aeson.parseJSON data'+parseDispatchData GUILD_DELETE data' = GuildDelete <$> Aeson.parseJSON data'+parseDispatchData GUILD_BAN_ADD data' = GuildBanAdd <$> Aeson.parseJSON data'+parseDispatchData GUILD_BAN_REMOVE data' = GuildBanRemove <$> Aeson.parseJSON data'+parseDispatchData GUILD_EMOJIS_UPDATE data' = GuildEmojisUpdate <$> Aeson.parseJSON data'+parseDispatchData GUILD_INTEGRATIONS_UPDATE data' = GuildIntegrationsUpdate <$> Aeson.parseJSON data'+parseDispatchData GUILD_MEMBER_ADD data' = do+  guildID <- Aeson.withObject "GuildMemberAdd.guild_id" (Aeson..: "guild_id") data'+  GuildMemberAdd guildID <$> Aeson.parseJSON data'+parseDispatchData GUILD_MEMBER_REMOVE data' = GuildMemberRemove <$> Aeson.parseJSON data'+parseDispatchData GUILD_MEMBER_UPDATE data' = GuildMemberUpdate <$> Aeson.parseJSON data'+parseDispatchData GUILD_MEMBERS_CHUNK data' = GuildMembersChunk <$> Aeson.parseJSON data'+parseDispatchData GUILD_ROLE_CREATE data' = GuildRoleCreate <$> Aeson.parseJSON data'+parseDispatchData GUILD_ROLE_UPDATE data' = GuildRoleUpdate <$> Aeson.parseJSON data'+parseDispatchData GUILD_ROLE_DELETE data' = GuildRoleDelete <$> Aeson.parseJSON data'+parseDispatchData INVITE_CREATE data' = InviteCreate <$> Aeson.parseJSON data'+parseDispatchData INVITE_DELETE data' = InviteDelete <$> Aeson.parseJSON data'+parseDispatchData MESSAGE_CREATE data' = do+  message <- Aeson.parseJSON data'+  let member =+        parseMaybe+          ( Aeson.withObject "MessageCreate.member" $ \o -> do+              userObject :: Aeson.Object <- o Aeson..: "author"+              memberObject :: Aeson.Object <- o Aeson..: "member"+              Aeson.parseJSON $ Aeson.Object (memberObject <> "user" Aeson..= userObject)+          )+          data' -  let user = parseMaybe parseJSON =<< data' ^? _Object . ix "author"+  let user = parseMaybe Aeson.parseJSON =<< data' ^? _Object % ix "author"   pure $ MessageCreate message user member-parseDispatchData MESSAGE_UPDATE data'              = do-  message <- parseJSON data'-  let member = parseMaybe (withObject "MessageCreate.member" $ \o -> do-                                         userObject :: Object <- o .: "author"-                                         memberObject :: Object <- o .: "member"-                                         parseJSON $ Object (memberObject <> "user" .= userObject)) data'-  let user = parseMaybe parseJSON =<< data' ^? _Object . ix "author"+parseDispatchData MESSAGE_UPDATE data' = do+  message <- Aeson.parseJSON data'+  let member =+        parseMaybe+          ( Aeson.withObject "MessageCreate.member" $ \o -> do+              userObject :: Aeson.Object <- o Aeson..: "author"+              memberObject :: Aeson.Object <- o Aeson..: "member"+              Aeson.parseJSON $ Aeson.Object (memberObject <> "user" Aeson..= userObject)+          )+          data'+  let user = parseMaybe Aeson.parseJSON =<< data' ^? _Object % ix "author"   pure $ MessageUpdate message user member-parseDispatchData MESSAGE_DELETE data'              = MessageDelete <$> parseJSON data'-parseDispatchData MESSAGE_DELETE_BULK data'         = MessageDeleteBulk <$> parseJSON data'-parseDispatchData MESSAGE_REACTION_ADD data'        = MessageReactionAdd <$> parseJSON data'-parseDispatchData MESSAGE_REACTION_REMOVE data'     = MessageReactionRemove <$> parseJSON data'-parseDispatchData MESSAGE_REACTION_REMOVE_ALL data' = MessageReactionRemoveAll <$> parseJSON data'-parseDispatchData PRESENCE_UPDATE data'             = PresenceUpdate <$> parseJSON data'-parseDispatchData TYPING_START data'                = TypingStart <$> parseJSON data'-parseDispatchData USER_UPDATE data'                 = UserUpdate <$> parseJSON data'-parseDispatchData VOICE_STATE_UPDATE data'          = VoiceStateUpdate <$> parseJSON data'-parseDispatchData VOICE_SERVER_UPDATE data'         = VoiceServerUpdate <$> parseJSON data'-parseDispatchData WEBHOOKS_UPDATE data'             = WebhooksUpdate <$> parseJSON data'-parseDispatchData INTERACTION_CREATE data'          = InteractionCreate <$> parseJSON data'+parseDispatchData MESSAGE_DELETE data' = MessageDelete <$> Aeson.parseJSON data'+parseDispatchData MESSAGE_DELETE_BULK data' = MessageDeleteBulk <$> Aeson.parseJSON data'+parseDispatchData MESSAGE_REACTION_ADD data' = MessageReactionAdd <$> Aeson.parseJSON data'+parseDispatchData MESSAGE_REACTION_REMOVE data' = MessageReactionRemove <$> Aeson.parseJSON data'+parseDispatchData MESSAGE_REACTION_REMOVE_ALL data' = MessageReactionRemoveAll <$> Aeson.parseJSON data'+parseDispatchData PRESENCE_UPDATE data' = PresenceUpdate <$> Aeson.parseJSON data'+parseDispatchData TYPING_START data' = TypingStart <$> Aeson.parseJSON data'+parseDispatchData USER_UPDATE data' = UserUpdate <$> Aeson.parseJSON data'+parseDispatchData VOICE_STATE_UPDATE data' = VoiceStateUpdate <$> Aeson.parseJSON data'+parseDispatchData VOICE_SERVER_UPDATE data' = VoiceServerUpdate <$> Aeson.parseJSON data'+parseDispatchData WEBHOOKS_UPDATE data' = WebhooksUpdate <$> Aeson.parseJSON data'+parseDispatchData INTERACTION_CREATE data' = InteractionCreate <$> Aeson.parseJSON data'  data SentDiscordMessage   = StatusUpdate StatusUpdateData@@ -152,32 +157,22 @@   | VoiceStatusUpdate VoiceState   | Resume ResumeData   | RequestGuildMembers RequestGuildMembersData-  deriving ( Show, Generic )--instance ToJSON SentDiscordMessage where-  toJSON (HeartBeat data') = object ["op" .= (1 :: Int), "d" .= data']--  toJSON (Identify data') = object ["op" .= (2 :: Int), "d" .= data']--  toJSON (StatusUpdate data') = object ["op" .= (3 :: Int), "d" .= data']--  toJSON (VoiceStatusUpdate data') = object ["op" .= (4 :: Int), "d" .= data']--  toJSON (Resume data') = object ["op" .= (6 :: Int), "d" .= data']--  toJSON (RequestGuildMembers data') = object ["op" .= (8 :: Int), "d" .= data']--  toEncoding (HeartBeat data') = pairs ("op" .= (1 :: Int) <> "d" .= data')--  toEncoding (Identify data') = pairs ("op" .= (2 :: Int) <> "d" .= data')--  toEncoding (StatusUpdate data') = pairs ("op" .= (3 :: Int) <> "d" .= data')--  toEncoding (VoiceStatusUpdate data') = pairs ("op" .= (4 :: Int) <> "d" .= data')+  deriving (Show) -  toEncoding (Resume data') = pairs ("op" .= (6 :: Int) <> "d" .= data')+instance Aeson.ToJSON SentDiscordMessage where+  toJSON (HeartBeat data') = Aeson.object ["op" Aeson..= (1 :: Int), "d" Aeson..= data']+  toJSON (Identify data') = Aeson.object ["op" Aeson..= (2 :: Int), "d" Aeson..= data']+  toJSON (StatusUpdate data') = Aeson.object ["op" Aeson..= (3 :: Int), "d" Aeson..= data']+  toJSON (VoiceStatusUpdate data') = Aeson.object ["op" Aeson..= (4 :: Int), "d" Aeson..= data']+  toJSON (Resume data') = Aeson.object ["op" Aeson..= (6 :: Int), "d" Aeson..= data']+  toJSON (RequestGuildMembers data') = Aeson.object ["op" Aeson..= (8 :: Int), "d" Aeson..= data'] -  toEncoding (RequestGuildMembers data') = pairs ("op" .= (8 :: Int) <> "d" .= data')+  toEncoding (HeartBeat data') = Aeson.pairs ("op" Aeson..= (1 :: Int) <> "d" Aeson..= data')+  toEncoding (Identify data') = Aeson.pairs ("op" Aeson..= (2 :: Int) <> "d" Aeson..= data')+  toEncoding (StatusUpdate data') = Aeson.pairs ("op" Aeson..= (3 :: Int) <> "d" Aeson..= data')+  toEncoding (VoiceStatusUpdate data') = Aeson.pairs ("op" Aeson..= (4 :: Int) <> "d" Aeson..= data')+  toEncoding (Resume data') = Aeson.pairs ("op" Aeson..= (6 :: Int) <> "d" Aeson..= data')+  toEncoding (RequestGuildMembers data') = Aeson.pairs ("op" Aeson..= (8 :: Int) <> "d" Aeson..= data')  -- Thanks sbrg: -- https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hs@@ -218,89 +213,126 @@   | VOICE_SERVER_UPDATE   | WEBHOOKS_UPDATE   | INTERACTION_CREATE-  deriving ( Show, Eq, Enum, Generic )-  deriving anyclass ( ToJSON, FromJSON )+  deriving (Show, Eq, Enum, Generic)+  deriving (Aeson.ToJSON, Aeson.FromJSON)  data IdentifyData = IdentifyData-  { token          :: Text-  , properties     :: IdentifyProps-  , compress       :: Bool-  , largeThreshold :: Int-  , shard          :: (Int, Int)-  , presence       :: Maybe StatusUpdateData-  , intents        :: Intents+  { token :: Text+  , properties :: IdentifyProps+  , compress :: Bool+  , largeThreshold :: Maybe Int+  , shard :: Maybe (Int, Int)+  , presence :: Maybe StatusUpdateData+  , intents :: Intents   }-  deriving ( Show, Generic )-  deriving ToJSON via CalamityJSON IdentifyData+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON IdentifyData +instance CalamityToJSON' IdentifyData where+  toPairs IdentifyData {..} =+    [ "token" .= token+    , "properties" .= properties+    , "compress" .= compress+    , "large_threshold" .?= largeThreshold+    , "shard" .?= shard+    , "presence" .?= presence+    , "intents" .= intents+    ]+ data StatusUpdateData = StatusUpdateData-  { since  :: Maybe Integer-  , game   :: Maybe Activity+  { since :: Maybe Integer+  , activities :: [Activity]   , status :: StatusType-  , afk    :: Bool+  , afk :: Bool   }-  deriving ( Show, Generic )-  deriving ToJSON via CalamityJSONKeepNothing StatusUpdateData+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON StatusUpdateData +instance CalamityToJSON' StatusUpdateData where+  toPairs StatusUpdateData {..} =+    [ "since" .= since+    , "activities" .= activities+    , "status" .= status+    , "afk" .= afk+    ]+ data ResumeData = ResumeData-  { token     :: Text+  { token :: Text   , sessionID :: Text-  , seq       :: Int+  , seq :: Int   }-  deriving ( Show, Generic )-  deriving ( ToJSON, FromJSON ) via CalamityJSON ResumeData+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON ResumeData +instance CalamityToJSON' ResumeData where+  toPairs ResumeData {..} =+    [ "token" .= token+    , "session_id" .= sessionID+    , "seq" .= seq+    ]+ data RequestGuildMembersData = RequestGuildMembersData   { guildID :: Snowflake Guild-  , query   :: Maybe Text-  , limit   :: Maybe Int+  , query :: Maybe Text+  , limit :: Int+  , presences :: Maybe Bool+  , userIDs :: Maybe [Snowflake User]+  , nonce :: Maybe Text   }-  deriving ( Show, Generic )+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON RequestGuildMembersData -instance ToJSON RequestGuildMembersData where-  toJSON RequestGuildMembersData { guildID, query, limit } =-    object ["guild_id" .= guildID, "query" .= fromMaybe "" query, "limit" .= fromMaybe 0 limit]+instance CalamityToJSON' RequestGuildMembersData where+  toPairs RequestGuildMembersData {..} =+    [ "guild_id" .= guildID+    , "query" .?= query+    , "limit" .= limit+    , "presences" .?= presences+    , "user_ids" .?= userIDs+    , "nonce" .?= nonce+    ]  data IdentifyProps = IdentifyProps   { browser :: Text-  , device  :: Text+  , device :: Text   }-  deriving ( Show, Generic )+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON IdentifyProps -instance ToJSON IdentifyProps where-  toJSON IdentifyProps { browser, device } = object ["$browser" .= browser, "$device" .= device]+instance CalamityToJSON' IdentifyProps where+  toPairs IdentifyProps {..} = ["$browser" .= browser, "$device" .= device]  data ControlMessage   = RestartShard   | ShutDownShard   | SendPresence StatusUpdateData-  deriving ( Show, Generic )+  deriving (Show)  data ShardFlowControl   = ShardFlowRestart   | ShardFlowShutDown-  deriving ( Show, Generic )-  deriving ( TextShow ) via TSG.FromGeneric ShardFlowControl+  deriving (Show)  data Shard = Shard-  { shardID       :: Int-  , shardCount    :: Int-  , gateway       :: Text-  , evtIn         :: InChan CalamityEvent-  , cmdOut        :: OutChan ControlMessage-  , token         :: Text+  { shardID :: Int+  , shardCount :: Int+  , gateway :: Text+  , evtIn :: InChan CalamityEvent+  , cmdOut :: OutChan ControlMessage+  , token :: Text   , initialStatus :: Maybe StatusUpdateData-  , intents       :: Intents+  , intents :: Intents   }-  deriving ( Generic )  data ShardState = ShardState-  { shardS     :: Shard-  , seqNum     :: Maybe Int-  , hbThread   :: Maybe (Async (Maybe ()))+  { shardS :: Shard+  , seqNum :: Maybe Int+  , hbThread :: Maybe (Async (Maybe ()))   , hbResponse :: Bool-  , wsHost     :: Maybe Text-  , sessionID  :: Maybe Text-  , wsConn     :: Maybe Connection+  , wsHost :: Maybe Text+  , sessionID :: Maybe Text+  , wsConn :: Maybe Connection   }-  deriving ( Generic )++$(makeFieldLabelsNoPrefix ''Shard)+$(makeFieldLabelsNoPrefix ''ShardState)

@@ -6,16 +6,11 @@  import Calamity.HTTP.Internal.Request import Calamity.HTTP.Internal.Route-import Calamity.Internal.Utils () import Calamity.Types.Model.Guild import Calamity.Types.Model.User import Calamity.Types.Snowflake--import Control.Lens- import Data.Default.Class--import GHC.Generics+import Data.Function ((&))  data GetAuditLogOptions = GetAuditLogOptions   { userID :: Maybe (Snowflake User)@@ -23,8 +18,11 @@   , before :: Maybe (Snowflake AuditLogEntry)   , limit :: Maybe Integer   }-  deriving (Show, Generic, Default)+  deriving (Show) +instance Default GetAuditLogOptions where+  def = GetAuditLogOptions Nothing Nothing Nothing Nothing+ data AuditLogRequest a where   GetAuditLog :: HasID Guild g => g -> GetAuditLogOptions -> AuditLogRequest AuditLog @@ -36,7 +34,7 @@       & giveID gid       & buildRoute -  action (GetAuditLog _ GetAuditLogOptions{userID, actionType, before, limit}) =+  action (GetAuditLog _ GetAuditLogOptions {userID, actionType, before, limit}) =     getWithP       ( "user_id" =:? (fromSnowflake <$> userID)           <> "action_type" =:? (fromEnum <$> actionType)

@@ -1,3 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+ -- | Channel endpoints module Calamity.HTTP.Channel (   ChannelRequest (..),@@ -21,7 +23,7 @@  import Calamity.HTTP.Internal.Request import Calamity.HTTP.Internal.Route-import Calamity.Internal.AesonThings+import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=)) import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild.Emoji (RawEmoji (..)) import Calamity.Types.Model.Guild.Invite (Invite)@@ -29,8 +31,7 @@ import Calamity.Types.Model.Guild.Role (Role) import Calamity.Types.Model.User import Calamity.Types.Snowflake-import Control.Lens hiding ((.=))-import Data.Aeson+import qualified Data.Aeson as Aeson import qualified Data.Aeson.KeyMap as K import Data.ByteString.Lazy (ByteString) import Data.Default.Class@@ -38,10 +39,10 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Word-import GHC.Generics import Network.HTTP.Client.MultipartFormData import Network.HTTP.Req import Network.Mime+import Optics import PyF import TextShow @@ -50,7 +51,7 @@   , description :: Maybe Text   , content :: ByteString   }-  deriving (Show, Generic)+  deriving (Show)  data CreateMessageOptions = CreateMessageOptions   { content :: Maybe Text@@ -62,16 +63,26 @@   , messageReference :: Maybe MessageReference   , components :: Maybe [Component]   }-  deriving (Show, Generic, Default)+  deriving (Show) +instance Default CreateMessageOptions where+  def = CreateMessageOptions Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing+ data CreateMessageAttachmentJson = CreateMessageAttachmentJson   { id :: Int   , filename :: Text   , description :: Maybe Text   }-  deriving (Show, Generic)-  deriving (ToJSON) via CalamityJSON CreateMessageAttachmentJson+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON CreateMessageAttachmentJson +instance CalamityToJSON' CreateMessageAttachmentJson where+  toPairs CreateMessageAttachmentJson {..} =+    [ "filename" .= filename+    , "description" .?= description+    , "id" .= id+    ]+ data CreateMessageJson = CreateMessageJson   { content :: Maybe Text   , nonce :: Maybe Text@@ -82,19 +93,31 @@   , components :: Maybe [Component]   , attachments :: Maybe [CreateMessageAttachmentJson]   }-  deriving (Show, Generic)-  deriving (ToJSON) via CalamityJSON CreateMessageJson+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON CreateMessageJson +instance CalamityToJSON' CreateMessageJson where+  toPairs CreateMessageJson {..} =+    [ "content" .?= content+    , "nonce" .?= nonce+    , "tts" .?= tts+    , "embeds" .?= embeds+    , "allowed_mentions" .?= allowedMentions+    , "message_reference" .?= messageReference+    , "components" .?= components+    , "attachments" .?= attachments+    ]+ data AllowedMentionType   = AllowedMentionRoles   | AllowedMentionUsers   | AllowedMentionEveryone-  deriving (Show, Generic)+  deriving (Show) -instance ToJSON AllowedMentionType where-  toJSON AllowedMentionRoles = String "roles"-  toJSON AllowedMentionUsers = String "users"-  toJSON AllowedMentionEveryone = String "everyone"+instance Aeson.ToJSON AllowedMentionType where+  toJSON AllowedMentionRoles = Aeson.String "roles"+  toJSON AllowedMentionUsers = Aeson.String "users"+  toJSON AllowedMentionEveryone = Aeson.String "everyone"  data AllowedMentions = AllowedMentions   { parse :: [AllowedMentionType]@@ -102,9 +125,17 @@   , users :: [Snowflake User]   , repliedUser :: Bool   }-  deriving (Show, Generic)-  deriving (ToJSON) via CalamityJSON AllowedMentions+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON AllowedMentions +instance CalamityToJSON' AllowedMentions where+  toPairs AllowedMentions {..} =+    [ "parse" .= parse+    , "roles" .= roles+    , "users" .= users+    , "replied_user" .= repliedUser+    ]+ instance Default AllowedMentions where   def = AllowedMentions def def def False @@ -125,24 +156,24 @@  >>> encode $ editMessageContent (Just "test") <> editMessageFlags Nothing  "{\"nick\":\"test\",\"deaf\":null}" -}-newtype EditMessageData = EditMessageData Object-  deriving (Show, Generic)-  deriving newtype (ToJSON, Semigroup, Monoid)+newtype EditMessageData = EditMessageData Aeson.Object+  deriving stock (Show)+  deriving newtype (Aeson.ToJSON, Semigroup, Monoid)  editMessageContent :: Maybe Text -> EditMessageData-editMessageContent v = EditMessageData $ K.fromList [("content", toJSON v)]+editMessageContent v = EditMessageData $ K.fromList [("content", Aeson.toJSON v)]  editMessageEmbeds :: [Embed] -> EditMessageData-editMessageEmbeds v = EditMessageData $ K.fromList [("embeds", toJSON v)]+editMessageEmbeds v = EditMessageData $ K.fromList [("embeds", Aeson.toJSON v)]  editMessageFlags :: Maybe Word64 -> EditMessageData-editMessageFlags v = EditMessageData $ K.fromList [("flags", toJSON v)]+editMessageFlags v = EditMessageData $ K.fromList [("flags", Aeson.toJSON v)]  editMessageAllowedMentions :: Maybe AllowedMentions -> EditMessageData-editMessageAllowedMentions v = EditMessageData $ K.fromList [("allowed_mentions", toJSON v)]+editMessageAllowedMentions v = EditMessageData $ K.fromList [("allowed_mentions", Aeson.toJSON v)]  editMessageComponents :: [Component] -> EditMessageData-editMessageComponents v = EditMessageData $ K.fromList [("components", toJSON v)]+editMessageComponents v = EditMessageData $ K.fromList [("components", Aeson.toJSON v)]  data ChannelUpdate = ChannelUpdate   { name :: Maybe Text@@ -155,9 +186,25 @@   , permissionOverwrites :: Maybe [Overwrite]   , parentID :: Maybe (Snowflake Channel)   }-  deriving (Generic, Show, Default)-  deriving (ToJSON) via CalamityJSON ChannelUpdate+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON ChannelUpdate +instance Default ChannelUpdate where+  def = ChannelUpdate Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing++instance CalamityToJSON' ChannelUpdate where+  toPairs ChannelUpdate {..} =+    [ "name" .?= name+    , "position" .?= position+    , "topic" .?= topic+    , "nsfw" .?= nsfw+    , "rate_limit_per_user" .?= rateLimitPerUser+    , "bitrate" .?= bitrate+    , "user_limit" .?= userLimit+    , "permission_overwrites" .?= permissionOverwrites+    , "parent_id" .?= parentID+    ]+ data ChannelMessagesFilter   = ChannelMessagesAround       { around :: Snowflake Message@@ -168,37 +215,73 @@   | ChannelMessagesAfter       { after :: Snowflake Message       }-  deriving (Generic, Show)-  deriving (ToJSON) via CalamityJSON ChannelMessagesFilter+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON ChannelMessagesFilter +instance CalamityToJSON' ChannelMessagesFilter where+  toPairs ChannelMessagesAround {around} = ["around" .= around]+  toPairs ChannelMessagesBefore {before} = ["before" .= before]+  toPairs ChannelMessagesAfter {after} = ["after" .= after]+ newtype ChannelMessagesLimit = ChannelMessagesLimit   { limit :: Integer   }-  deriving (Generic, Show)+  deriving stock (Show)  data GetReactionsOptions = GetReactionsOptions   { before :: Maybe (Snowflake User)   , after :: Maybe (Snowflake User)   , limit :: Maybe Integer   }-  deriving (Show, Generic, Default)+  deriving (Show) +instance Default GetReactionsOptions where+  def = GetReactionsOptions Nothing Nothing Nothing+ data CreateChannelInviteOptions = CreateChannelInviteOptions   { maxAge :: Maybe Int   , maxUses :: Maybe Int   , temporary :: Maybe Bool   , unique :: Maybe Bool   }-  deriving (Show, Generic, Default)-  deriving (ToJSON) via CalamityJSON CreateChannelInviteOptions+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON CreateChannelInviteOptions +instance Default CreateChannelInviteOptions where+  def = CreateChannelInviteOptions Nothing Nothing Nothing Nothing++instance CalamityToJSON' CreateChannelInviteOptions where+  toPairs CreateChannelInviteOptions {..} =+    [ "max_age" .?= maxAge+    , "max_uses" .?= maxUses+    , "temporary" .?= temporary+    , "unique" .?= unique+    ]+ data GroupDMAddRecipientOptions = GroupDMAddRecipientOptions   { accessToken :: Text   , nick :: Text   }-  deriving (Show, Generic)-  deriving (ToJSON) via CalamityJSON GroupDMAddRecipientOptions+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON GroupDMAddRecipientOptions +instance CalamityToJSON' GroupDMAddRecipientOptions where+  toPairs GroupDMAddRecipientOptions {..} =+    [ "access_token" .= accessToken+    , "nick" .= nick+    ]++$(makeFieldLabelsNoPrefix ''CreateMessageAttachment)+$(makeFieldLabelsNoPrefix ''CreateMessageOptions)+$(makeFieldLabelsNoPrefix ''CreateMessageAttachmentJson)+$(makeFieldLabelsNoPrefix ''AllowedMentions)+$(makeFieldLabelsNoPrefix ''ChannelUpdate)+$(makeFieldLabelsNoPrefix ''ChannelMessagesFilter)+$(makeFieldLabelsNoPrefix ''ChannelMessagesLimit)+$(makeFieldLabelsNoPrefix ''GetReactionsOptions)+$(makeFieldLabelsNoPrefix ''CreateChannelInviteOptions)+$(makeFieldLabelsNoPrefix ''GroupDMAddRecipientOptions)+ data ChannelRequest a where   CreateMessage :: (HasID Channel c) => c -> CreateMessageOptions -> ChannelRequest Message   CrosspostMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest Message@@ -354,19 +437,19 @@             , components = cm ^. #components             , attachments = attachments             }-    body <- reqBodyMultipart (partLBS "payload_json" (encode jsonBody) : files)+    body <- reqBodyMultipart (partLBS "payload_json" (Aeson.encode jsonBody) : files)     postWith' body u o   action (CrosspostMessage _ _) = postEmpty   action (GetChannel _) = getWith   action (ModifyChannel _ p) = patchWith' (ReqBodyJson p)   action (DeleteChannel _) = deleteWith   action (GetChannelMessages _ (Just (ChannelMessagesAround (fromSnowflake -> a))) l) =-    getWithP ("around" =: a <> "limit" =:? (l ^? _Just . #limit))+    getWithP ("around" =: a <> "limit" =:? (l ^? _Just % #limit))   action (GetChannelMessages _ (Just (ChannelMessagesBefore (fromSnowflake -> a))) l) =-    getWithP ("before" =: a <> "limit" =:? (l ^? _Just . #limit))+    getWithP ("before" =: a <> "limit" =:? (l ^? _Just % #limit))   action (GetChannelMessages _ (Just (ChannelMessagesAfter (fromSnowflake -> a))) l) =-    getWithP ("after" =: a <> "limit" =:? (l ^? _Just . #limit))-  action (GetChannelMessages _ Nothing l) = getWithP ("limit" =:? (l ^? _Just . #limit))+    getWithP ("after" =: a <> "limit" =:? (l ^? _Just % #limit))+  action (GetChannelMessages _ Nothing l) = getWithP ("limit" =:? (l ^? _Just % #limit))   action (GetMessage _ _) = getWith   action CreateReaction {} = putEmpty   action DeleteOwnReaction {} = deleteWith@@ -380,7 +463,7 @@   action (DeleteAllReactions _ _) = deleteWith   action (EditMessage _ _ o) = patchWith' (ReqBodyJson o)   action (DeleteMessage _ _) = deleteWith-  action (BulkDeleteMessages _ (map (getID @Message) -> ids)) = postWith' (ReqBodyJson $ object ["messages" .= ids])+  action (BulkDeleteMessages _ (map (getID @Message) -> ids)) = postWith' (ReqBodyJson $ Aeson.object ["messages" Aeson..= ids])   action (GetChannelInvites _) = getWith   action (CreateChannelInvite _ o) = postWith' (ReqBodyJson o)   action (EditChannelPermissions _ o) = putWith' (ReqBodyJson o)@@ -391,3 +474,4 @@   action (DeletePinnedMessage _ _) = deleteWith   action (GroupDMAddRecipient _ _ o) = putWith' (ReqBodyJson o)   action (GroupDMRemoveRecipient _ _) = deleteWith+

@@ -1,3 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+ -- | Emoji endpoints module Calamity.HTTP.Emoji (   EmojiRequest (..),@@ -7,34 +9,43 @@  import Calamity.HTTP.Internal.Request import Calamity.HTTP.Internal.Route-import Calamity.Internal.AesonThings-import Calamity.Internal.Utils ()+import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=)) import Calamity.Types.Model.Guild import Calamity.Types.Snowflake--import Data.Aeson+import qualified Data.Aeson as Aeson import Data.Function import Data.Text (Text)--import GHC.Generics- import Network.HTTP.Req+import Optics.TH  data CreateGuildEmojiOptions = CreateGuildEmojiOptions   { name :: Text   , image :: Text   , roles :: [Snowflake Role]   }-  deriving (Show, Generic)-  deriving (ToJSON) via CalamityJSON CreateGuildEmojiOptions+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON CreateGuildEmojiOptions +instance CalamityToJSON' CreateGuildEmojiOptions where+  toPairs CreateGuildEmojiOptions {..} =+    [ "name" .= name+    , "image" .= image+    , "roles" .= roles+    ]+ data ModifyGuildEmojiOptions = ModifyGuildEmojiOptions   { name :: Text   , roles :: [Snowflake Role]   }-  deriving (Show, Generic)-  deriving (ToJSON) via CalamityJSON ModifyGuildEmojiOptions+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON ModifyGuildEmojiOptions +instance CalamityToJSON' ModifyGuildEmojiOptions where+  toPairs ModifyGuildEmojiOptions {..} =+    [ "name" .= name+    , "roles" .= roles+    ]+ data EmojiRequest a where   ListGuildEmojis :: (HasID Guild g) => g -> EmojiRequest [Emoji]   GetGuildEmoji :: (HasID Guild g, HasID Emoji e) => g -> e -> EmojiRequest Emoji@@ -68,3 +79,6 @@   action (CreateGuildEmoji _ o) = postWith' (ReqBodyJson o)   action (ModifyGuildEmoji _ _ o) = patchWith' (ReqBodyJson o)   action (DeleteGuildEmoji _ _) = deleteWith++$(makeFieldLabelsNoPrefix ''CreateGuildEmojiOptions)+$(makeFieldLabelsNoPrefix ''ModifyGuildEmojiOptions)

@@ -1,3 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+ -- | Guild endpoints module Calamity.HTTP.Guild (   GuildRequest (..),@@ -7,14 +9,14 @@   ChannelPosition (..),   ListMembersOptions (..),   AddGuildMemberData (..),-  ModifyGuildMemberData (..),+  ModifyGuildMemberData,   modifyGuildMemberNick,   modifyGuildMemberRoles,   modifyGuildMemberMute,   modifyGuildMemberDeaf,   modifyGuildMemberChannelID,   CreateGuildBanData (..),-  ModifyGuildRoleData (..),+  ModifyGuildRoleData,   modifyGuildRoleName,   modifyGuildRolePermissions,   modifyGuildRoleColour,@@ -25,23 +27,20 @@  import Calamity.HTTP.Internal.Request import Calamity.HTTP.Internal.Route-import Calamity.Internal.AesonThings import Calamity.Internal.IntColour+import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=)) import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild import Calamity.Types.Model.User import Calamity.Types.Model.Voice import Calamity.Types.Snowflake-import Control.Lens hiding ((.=))-import Data.Aeson+import qualified Data.Aeson as Aeson import qualified Data.Aeson.KeyMap as K-import Data.Aeson.Lens import Data.Colour (Colour) import Data.Default.Class import Data.Text (Text)-import GHC.Generics import Network.HTTP.Req-import TextShow+import Optics  data CreateGuildData = CreateGuildData   { name :: Text@@ -53,9 +52,21 @@   , roles :: [Role]   , channels :: [Partial Channel]   }-  deriving (Show, Generic)-  deriving (ToJSON) via CalamityJSON CreateGuildData+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON CreateGuildData +instance CalamityToJSON' CreateGuildData where+  toPairs CreateGuildData {..} =+    [ "name" .= name+    , "region" .= region+    , "icon" .= icon+    , "verification_level" .= verificationLevel+    , "default_message_notifications" .= defaultMessageNotifications+    , "explicit_content_filter" .= explicitContentFilter+    , "roles" .= roles+    , "channels" .= channels+    ]+ data ModifyGuildData = ModifyGuildData   { name :: Maybe Text   , region :: Maybe Text@@ -70,9 +81,41 @@   , banner :: Maybe Text   , systemChannelID :: Maybe (Snowflake GuildChannel)   }-  deriving (Show, Generic, Default)-  deriving (ToJSON) via CalamityJSON ModifyGuildData+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON ModifyGuildData +instance Default ModifyGuildData where+  def =+    ModifyGuildData+      Nothing+      Nothing+      Nothing+      Nothing+      Nothing+      Nothing+      Nothing+      Nothing+      Nothing+      Nothing+      Nothing+      Nothing++-- TODO: Make this work properly, a la modifyguildmember+instance CalamityToJSON' ModifyGuildData where+  toPairs ModifyGuildData {..} =+    [ "name" .?= name+    , "region" .?= region+    , "icon" .?= icon+    , "verification_level" .?= verificationLevel+    , "default_message_notifications" .?= defaultMessageNotifications+    , "explicit_content_filter" .?= explicitContentFilter+    , "afk_timeout" .?= afkTimeout+    , "owner_id" .?= ownerID+    , "splash" .?= splash+    , "banner" .?= banner+    , "system_channel_id" .?= systemChannelID+    ]+ data ChannelCreateData = ChannelCreateData   { name :: Text   , type_ :: Maybe ChannelType@@ -85,28 +128,69 @@   , parentID :: Maybe (Snowflake Category)   , nsfw :: Maybe Bool   }-  deriving (Show, Generic)-  deriving (ToJSON) via CalamityJSON ChannelCreateData+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON ChannelCreateData +instance CalamityToJSON' ChannelCreateData where+  toPairs ChannelCreateData {..} =+    [ "name" .= name+    , "type" .?= type_+    , "topic" .?= topic+    , "bitrate" .?= bitrate+    , "user_limit" .?= userLimit+    , "rate_limit_per_user" .?= rateLimitPerUser+    , "position" .?= position+    , "permission_overwrites" .?= permissionOverwrites+    , "parent_id" .?= parentID+    , "nsfw" .?= nsfw+    ]+ data ChannelPosition = ChannelPosition   { id :: Snowflake GuildChannel   , position :: Maybe Integer+  , lockPermissions :: Maybe Bool+  , parentID :: Snowflake GuildChannel   }-  deriving (Show, Generic)-  deriving (ToJSON) via CalamityJSON ChannelPosition+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON ChannelPosition +instance CalamityToJSON' ChannelPosition where+  toPairs ChannelPosition {..} =+    [ "id" .= id+    , "position" .= position+    , "lock_permissions" .= lockPermissions+    , "parent_id" .= parentID+    ]+ data ListMembersOptions = ListMembersOptions   { limit :: Maybe Integer   , after :: Maybe (Snowflake User)   }-  deriving (Show, Generic, Default)+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON ListMembersOptions +instance Default ListMembersOptions where+  def = ListMembersOptions Nothing Nothing++instance CalamityToJSON' ListMembersOptions where+  toPairs ListMembersOptions {..} =+    [ "limit" .?= limit+    , "after" .?= after+    ]+ data SearchMembersOptions = SearchMembersOptions   { limit :: Maybe Integer   , query :: Text   }-  deriving (Show, Generic)+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON SearchMembersOptions +instance CalamityToJSON' SearchMembersOptions where+  toPairs SearchMembersOptions {..} =+    [ "limit" .?= limit+    , "query" .= query+    ]+ data AddGuildMemberData = AddGuildMemberData   { accessToken :: Text   , nick :: Maybe Text@@ -114,87 +198,108 @@   , mute :: Maybe Bool   , deaf :: Maybe Bool   }-  deriving (Show, Generic)-  deriving (ToJSON) via CalamityJSON AddGuildMemberData+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON AddGuildMemberData +instance CalamityToJSON' AddGuildMemberData where+  toPairs AddGuildMemberData {..} =+    [ "access_token" .= accessToken+    , "nick" .?= nick+    , "roles" .?= roles+    , "mute" .?= mute+    , "deaf" .?= deaf+    ]+ {- | Parameters to the Modify Guild Member endpoint.   Use the provided methods (@modifyGuildMemberX@) to create a value with the- field set, use the Semigroup instance to union the values.+ field set, use the Semigroup instance to combine modifications.   ==== Examples   >>> encode $ modifyGuildMemberNick (Just "test") <> modifyGuildMemberDeaf Nothing  "{\"nick\":\"test\",\"deaf\":null}" -}-newtype ModifyGuildMemberData = ModifyGuildMemberData Object-  deriving (Show, Generic)-  deriving newtype (ToJSON, Semigroup, Monoid)+newtype ModifyGuildMemberData = ModifyGuildMemberData Aeson.Object+  deriving stock (Show)+  deriving newtype (Aeson.ToJSON, Semigroup, Monoid)  modifyGuildMemberNick :: Maybe Text -> ModifyGuildMemberData-modifyGuildMemberNick v = ModifyGuildMemberData $ K.fromList [("nick", toJSON v)]+modifyGuildMemberNick v = ModifyGuildMemberData $ K.fromList [("nick", Aeson.toJSON v)]  modifyGuildMemberRoles :: Maybe [Snowflake Role] -> ModifyGuildMemberData-modifyGuildMemberRoles v = ModifyGuildMemberData $ K.fromList [("roles", toJSON v)]+modifyGuildMemberRoles v = ModifyGuildMemberData $ K.fromList [("roles", Aeson.toJSON v)]  modifyGuildMemberMute :: Maybe Bool -> ModifyGuildMemberData-modifyGuildMemberMute v = ModifyGuildMemberData $ K.fromList [("mute", toJSON v)]+modifyGuildMemberMute v = ModifyGuildMemberData $ K.fromList [("mute", Aeson.toJSON v)]  modifyGuildMemberDeaf :: Maybe Bool -> ModifyGuildMemberData-modifyGuildMemberDeaf v = ModifyGuildMemberData $ K.fromList [("deaf", toJSON v)]+modifyGuildMemberDeaf v = ModifyGuildMemberData $ K.fromList [("deaf", Aeson.toJSON v)]  modifyGuildMemberChannelID :: Maybe (Snowflake VoiceChannel) -> ModifyGuildMemberData-modifyGuildMemberChannelID v = ModifyGuildMemberData $ K.fromList [("channel_id", toJSON v)]+modifyGuildMemberChannelID v = ModifyGuildMemberData $ K.fromList [("channel_id", Aeson.toJSON v)]  data GetGuildBansOptions = GetGuildBansOptions   { limit :: Maybe Int   , before :: Maybe Int   , after :: Maybe Int   }-  deriving (Show, Generic, Default)+  deriving (Show) +instance Default GetGuildBansOptions where+  def = GetGuildBansOptions Nothing Nothing Nothing+ data CreateGuildBanData = CreateGuildBanData   { deleteMessageDays :: Maybe Integer   , reason :: Maybe Text   }-  deriving (Show, Generic, Default)+  deriving (Show) +instance Default CreateGuildBanData where+  def = CreateGuildBanData Nothing Nothing+ {- | Parameters to the Modify Guild Role endpoint.   Use the provided methods (@modifyGuildRoleX@) to create a value with the- field set, use the Semigroup instance to union the values.+ field set, use the Semigroup instance to combine parameters.   ==== Examples   >>> encode $ modifyGuildRoleName (Just "test") <> modifyGuildRolePermissions Nothing  "{\"name\":\"test\",\"permissions\":null}" -}-newtype ModifyGuildRoleData = ModifyGuildRoleData Object-  deriving (Show, Generic)-  deriving newtype (ToJSON, Semigroup, Monoid)+newtype ModifyGuildRoleData = ModifyGuildRoleData Aeson.Object+  deriving stock (Show)+  deriving newtype (Aeson.ToJSON, Semigroup, Monoid)  modifyGuildRoleName :: Maybe Text -> ModifyGuildRoleData-modifyGuildRoleName v = ModifyGuildRoleData $ K.fromList [("name", toJSON v)]+modifyGuildRoleName v = ModifyGuildRoleData $ K.fromList [("name", Aeson.toJSON v)]  modifyGuildRolePermissions :: Maybe Permissions -> ModifyGuildRoleData-modifyGuildRolePermissions v = ModifyGuildRoleData $ K.fromList [("permissions", toJSON v)]+modifyGuildRolePermissions v = ModifyGuildRoleData $ K.fromList [("permissions", Aeson.toJSON v)]  modifyGuildRoleColour :: Maybe (Colour Double) -> ModifyGuildRoleData-modifyGuildRoleColour v = ModifyGuildRoleData $ K.fromList [("colour", toJSON (IntColour <$> v))]+modifyGuildRoleColour v = ModifyGuildRoleData $ K.fromList [("colour", Aeson.toJSON (IntColour <$> v))]  modifyGuildRoleHoist :: Maybe Bool -> ModifyGuildRoleData-modifyGuildRoleHoist v = ModifyGuildRoleData $ K.fromList [("hoist", toJSON v)]+modifyGuildRoleHoist v = ModifyGuildRoleData $ K.fromList [("hoist", Aeson.toJSON v)]  modifyGuildRoleMentionable :: Maybe Bool -> ModifyGuildRoleData-modifyGuildRoleMentionable v = ModifyGuildRoleData $ K.fromList [("mentionable", toJSON v)]+modifyGuildRoleMentionable v = ModifyGuildRoleData $ K.fromList [("mentionable", Aeson.toJSON v)]  data ModifyGuildRolePositionsData = ModifyGuildRolePositionsData   { id :: Snowflake Role   , position :: Maybe Integer   }-  deriving (Show, Generic)-  deriving (ToJSON) via CalamityJSON ModifyGuildRolePositionsData+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON ModifyGuildRolePositionsData +instance CalamityToJSON' ModifyGuildRolePositionsData where+  toPairs ModifyGuildRolePositionsData {..} =+    [ "id" .= id+    , "postition" .?= position+    ]+ data GuildRequest a where   CreateGuild :: CreateGuildData -> GuildRequest Guild   GetGuild :: HasID Guild g => g -> GuildRequest Guild@@ -351,7 +456,7 @@       ("limit" =:? limit <> "query" =: query)   action (AddGuildMember _ _ o) = putWith' (ReqBodyJson o)   action (ModifyGuildMember _ _ o) = patchWith' (ReqBodyJson o)-  action (ModifyCurrentUserNick _ nick) = patchWith' (ReqBodyJson $ object ["nick" .= nick])+  action (ModifyCurrentUserNick _ nick) = patchWith' (ReqBodyJson $ Aeson.object ["nick" Aeson..= nick])   action AddGuildMemberRole {} = putEmpty   action RemoveGuildMemberRole {} = deleteWith   action (RemoveGuildMember _ _) = deleteWith@@ -376,3 +481,12 @@   -- this is a bit of a hack   -- TODO: add something to allow for contextual parsing   modifyResponse _ = Prelude.id++$(makeFieldLabelsNoPrefix ''CreateGuildData)+$(makeFieldLabelsNoPrefix ''ModifyGuildData)+$(makeFieldLabelsNoPrefix ''ChannelCreateData)+$(makeFieldLabelsNoPrefix ''ChannelPosition)+$(makeFieldLabelsNoPrefix ''ListMembersOptions)+$(makeFieldLabelsNoPrefix ''AddGuildMemberData)+$(makeFieldLabelsNoPrefix ''ModifyGuildRolePositionsData)+$(makeFieldLabelsNoPrefix ''CreateGuildBanData)

@@ -1,3 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+ -- | Interaction endpoints module Calamity.HTTP.Interaction (   InteractionRequest (..),@@ -10,14 +12,13 @@ import Calamity.HTTP.Channel (AllowedMentions, CreateMessageAttachment (..)) import Calamity.HTTP.Internal.Request import Calamity.HTTP.Internal.Route-import Calamity.Internal.AesonThings+import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=)) import Calamity.Types.Model.Channel.Component (Component, CustomID) import Calamity.Types.Model.Channel.Embed (Embed) import Calamity.Types.Model.Channel.Message (Message) import Calamity.Types.Model.Interaction import Calamity.Types.Snowflake-import Control.Lens hiding ((.=))-import Data.Aeson+import qualified Data.Aeson as Aeson import Data.Bits (shiftL, (.|.)) import Data.Default.Class import qualified Data.HashMap.Strict as H@@ -25,21 +26,25 @@ import Data.Monoid (First (First, getFirst)) import Data.Text (Text) import qualified Data.Text as T-import GHC.Generics import Network.HTTP.Client.MultipartFormData import Network.HTTP.Req import Network.Mime+import Optics import PyF-import TextShow-import qualified TextShow.Generic as TSG  data InteractionCallback = InteractionCallback   { type_ :: InteractionCallbackType-  , data_ :: Maybe Value+  , data_ :: Maybe Aeson.Value   }-  deriving (Show, Generic)-  deriving (ToJSON) via CalamityJSON InteractionCallback+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON InteractionCallback +instance CalamityToJSON' InteractionCallback where+  toPairs InteractionCallback {..} =+    [ "type" .= type_+    , "data" .?= data_+    ]+ data InteractionCallbackMessageOptions = InteractionCallbackMessageOptions   { tts :: Maybe Bool   , content :: Maybe Text@@ -50,16 +55,26 @@   , components :: Maybe [Component]   , attachments :: Maybe [CreateMessageAttachment]   }-  deriving (Show, Generic, Default)+  deriving (Show) +instance Default InteractionCallbackMessageOptions where+  def = InteractionCallbackMessageOptions Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing+ data CreateMessageAttachmentJson = CreateMessageAttachmentJson   { id :: Int   , filename :: Text   , description :: Maybe Text   }-  deriving (Show, Generic)-  deriving (ToJSON) via CalamityJSON CreateMessageAttachmentJson+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON CreateMessageAttachmentJson +instance CalamityToJSON' CreateMessageAttachmentJson where+  toPairs CreateMessageAttachmentJson {..} =+    [ "id" .= id+    , "filename" .= filename+    , "description" .?= description+    ]+ data CreateResponseMessageJson = CreateResponseMessageJson   { tts :: Maybe Bool   , content :: Maybe Text@@ -69,32 +84,60 @@   , components :: Maybe [Component]   , attachments :: Maybe [CreateMessageAttachmentJson]   }-  deriving (Show, Generic)-  deriving (ToJSON) via CalamityJSON CreateResponseMessageJson+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON CreateResponseMessageJson +instance CalamityToJSON' CreateResponseMessageJson where+  toPairs CreateResponseMessageJson {..} =+    [ "tts" .?= tts+    , "content" .?= content+    , "embeds" .?= embeds+    , "allowed_mentions" .?= allowedMentions+    , "flags" .?= flags+    , "components" .?= components+    , "attachments" .?= attachments+    ]+ newtype InteractionCallbackAutocomplete = InteractionCallbackAutocomplete   { choices :: [InteractionCallbackAutocompleteChoice]   }-  deriving stock (Show, Generic)-  deriving (ToJSON) via CalamityJSON InteractionCallbackAutocomplete+  deriving stock (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON InteractionCallbackAutocomplete +instance CalamityToJSON' InteractionCallbackAutocomplete where+  toPairs InteractionCallbackAutocomplete {..} = ["choices" .= choices]+ data InteractionCallbackAutocompleteChoice = InteractionCallbackAutocompleteChoice   { name :: Text   , nameLocalizations :: H.HashMap Text Text   , -- | Either text or numeric-    value :: Value+    value :: Aeson.Value   }-  deriving stock (Show, Generic)-  deriving (ToJSON) via CalamityJSON InteractionCallbackAutocompleteChoice+  deriving stock (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON InteractionCallbackAutocompleteChoice +instance CalamityToJSON' InteractionCallbackAutocompleteChoice where+  toPairs InteractionCallbackAutocompleteChoice {..} =+    [ "name" .= name+    , "name_localizations" .= nameLocalizations+    , "value" .= value+    ]+ data InteractionCallbackModal = InteractionCallbackModal   { customID :: CustomID   , title :: Text   , components :: [Component]   }-  deriving stock (Show, Generic)-  deriving (ToJSON) via CalamityJSON InteractionCallbackModal+  deriving stock (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON InteractionCallbackModal +instance CalamityToJSON' InteractionCallbackModal where+  toPairs InteractionCallbackModal {..} =+    [ "custom_id" .= customID+    , "title" .= title+    , "components" .= components+    ]+ data InteractionCallbackType   = PongType   | ChannelMessageWithSourceType@@ -103,11 +146,10 @@   | UpdateMessageType   | ApplicationCommandAutocompleteResultType   | ModalType-  deriving (Show, Generic)-  deriving (TextShow) via TSG.FromGeneric InteractionCallbackType+  deriving (Show) -instance ToJSON InteractionCallbackType where-  toEncoding ty = toEncoding @Int $ case ty of+instance Aeson.ToJSON InteractionCallbackType where+  toJSON ty = Aeson.toJSON @Int $ case ty of     PongType -> 1     ChannelMessageWithSourceType -> 4     DeferredChannelMessageWithSourceType -> 5@@ -115,7 +157,20 @@     UpdateMessageType -> 7     ApplicationCommandAutocompleteResultType -> 8     ModalType -> 9+  toEncoding ty = Aeson.toEncoding @Int $ case ty of+    PongType -> 1+    ChannelMessageWithSourceType -> 4+    DeferredChannelMessageWithSourceType -> 5+    DeferredUpdateMessageType -> 6+    UpdateMessageType -> 7+    ApplicationCommandAutocompleteResultType -> 8+    ModalType -> 9 +$(makeFieldLabelsNoPrefix ''InteractionCallbackMessageOptions)+$(makeFieldLabelsNoPrefix ''InteractionCallbackAutocomplete)+$(makeFieldLabelsNoPrefix ''InteractionCallbackAutocompleteChoice)+$(makeFieldLabelsNoPrefix ''InteractionCallbackModal)+ data InteractionRequest a where   CreateResponseMessage ::     (HasID Interaction i) =>@@ -257,7 +312,7 @@     let jsonBody =           InteractionCallback             { type_ = DeferredChannelMessageWithSourceType-            , data_ = if ephemeral then Just . object $ [("flags", Number 64)] else Nothing+            , data_ = if ephemeral then Just . Aeson.object $ [("flags", Aeson.Number 64)] else Nothing             }      in postWith' (ReqBodyJson jsonBody)   action (CreateResponseDeferComponent _ _) =@@ -293,9 +348,9 @@         jsonBody =           InteractionCallback             { type_ = ChannelMessageWithSourceType-            , data_ = Just . toJSON $ jsonData+            , data_ = Just . Aeson.toJSON $ jsonData             }-    body <- reqBodyMultipart (partLBS "payload_json" (encode jsonBody) : files)+    body <- reqBodyMultipart (partLBS "payload_json" (Aeson.encode jsonBody) : files)     postWith' body u o   action (CreateResponseUpdate _ _ cm) = \u o -> do     let filePart CreateMessageAttachment {filename, content} n =@@ -323,22 +378,22 @@         jsonBody =           InteractionCallback             { type_ = UpdateMessageType-            , data_ = Just . toJSON $ jsonData+            , data_ = Just . Aeson.toJSON $ jsonData             }-    body <- reqBodyMultipart (partLBS "payload_json" (encode jsonBody) : files)+    body <- reqBodyMultipart (partLBS "payload_json" (Aeson.encode jsonBody) : files)     postWith' body u o   action (CreateResponseAutocomplete _ _ ao) =     let jsonBody =           InteractionCallback             { type_ = ApplicationCommandAutocompleteResultType-            , data_ = Just . toJSON $ ao+            , data_ = Just . Aeson.toJSON $ ao             }      in postWith' (ReqBodyJson jsonBody)   action (CreateResponseModal _ _ mo) =     let jsonBody =           InteractionCallback             { type_ = ModalType-            , data_ = Just . toJSON $ mo+            , data_ = Just . Aeson.toJSON $ mo             }      in postWith' (ReqBodyJson jsonBody)   action (GetOriginalInteractionResponse _ _) = getWith@@ -368,9 +423,9 @@         jsonBody =           InteractionCallback             { type_ = UpdateMessageType-            , data_ = Just . toJSON $ jsonData+            , data_ = Just . Aeson.toJSON $ jsonData             }-    body <- reqBodyMultipart (partLBS "payload_json" (encode jsonBody) : files)+    body <- reqBodyMultipart (partLBS "payload_json" (Aeson.encode jsonBody) : files)     patchWith' body u o   action (DeleteOriginalInteractionResponse _ _) = deleteWith   action (CreateFollowupMessage _ _ cm) = \u o -> do@@ -396,7 +451,7 @@             , attachments = attachments             , flags = flags             }-    body <- reqBodyMultipart (partLBS "payload_json" (encode jsonData) : files)+    body <- reqBodyMultipart (partLBS "payload_json" (Aeson.encode jsonData) : files)     postWith' body u o   action GetFollowupMessage {} = getWith   action (EditFollowupMessage _ _ _ cm) = \u o -> do@@ -422,6 +477,6 @@             , attachments = attachments             , flags = flags             }-    body <- reqBodyMultipart (partLBS "payload_json" (encode jsonData) : files)+    body <- reqBodyMultipart (partLBS "payload_json" (Aeson.encode jsonData) : files)     patchWith' body u o   action DeleteFollowupMessage {} = deleteWith

@@ -19,10 +19,9 @@ import qualified Control.Concurrent.Event as E import Control.Concurrent.STM import qualified Control.Exception.Safe as Ex-import Control.Lens import Control.Monad-import Data.Aeson-import Data.Aeson.Lens+import qualified Data.Aeson as Aeson+import Data.Aeson.Optics import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB import Data.Maybe@@ -32,6 +31,8 @@ import Network.HTTP.Client (responseStatus) import Network.HTTP.Req import Network.HTTP.Types+import Optics+import Optics.Operators.Unsafe ((^?!)) import Polysemy (Sem, makeSem) import qualified Polysemy as P import PyF@@ -168,8 +169,8 @@             -- there are tokens remaining for us to use             modifyTVar'               (bucket ^. #state)-              ( (#remaining -~ 1)-                  . (#ongoing +~ 1)+              ( (#remaining %~ pred)+                  . (#ongoing %~ succ)               )             pure GoNow           else do@@ -240,31 +241,31 @@     computedEnd = flip addUTCTime now <$> resetAfter      resetAfter :: Maybe NominalDiffTime-    resetAfter = realToFrac <$> responseHeader r "X-Ratelimit-Reset-After" ^? _Just . _Double+    resetAfter = realToFrac <$> responseHeader r "X-Ratelimit-Reset-After" ^? _Just % _Double      end :: Maybe UTCTime     end =       posixSecondsToUTCTime . realToFrac-        <$> responseHeader r "X-Ratelimit-Reset" ^? _Just . _Double+        <$> responseHeader r "X-Ratelimit-Reset" ^? _Just % _Double  buildBucketState :: HttpResponse r => UTCTime -> r -> Maybe (BucketState, B.ByteString) buildBucketState now r = (,) <$> bs <*> bucketKey   where-    remaining = responseHeader r "X-RateLimit-Remaining" ^? _Just . _Integral-    limit = responseHeader r "X-RateLimit-Limit" ^? _Just . _Integral-    resetKey = ceiling <$> responseHeader r "X-RateLimit-Reset" ^? _Just . _Double+    remaining = responseHeader r "X-RateLimit-Remaining" ^? _Just % _Integral+    limit = responseHeader r "X-RateLimit-Limit" ^? _Just % _Integral+    resetKey = ceiling <$> responseHeader r "X-RateLimit-Reset" ^? _Just % _Double     resetTime = parseRateLimitHeader now r     bs = BucketState resetTime <$> resetKey <*> remaining <*> limit <*> pure 0     bucketKey = responseHeader r "X-RateLimit-Bucket"  -- | Parse the retry after field, returning when to retry-parseRetryAfter :: UTCTime -> Value -> UTCTime+parseRetryAfter :: UTCTime -> Aeson.Value -> UTCTime parseRetryAfter now r = addUTCTime retryAfter now   where-    retryAfter = realToFrac $ r ^?! key "retry_after" . _Double+    retryAfter = realToFrac $ r ^?! key "retry_after" % _Double -isGlobal :: Value -> Bool-isGlobal r = r ^? key "global" . _Bool == Just True+isGlobal :: Aeson.Value -> Bool+isGlobal r = r ^? key "global" % _Bool == Just True  -- Either (Either a a) b data ShouldRetry a b@@ -335,7 +336,7 @@       void . P.embed . atomically $ do         case rl of           KnownRatelimit bucket ->-            modifyTVar' (bucket ^. #state) (#ongoing -~ 1)+            modifyTVar' (bucket ^. #state) (#ongoing %~ succ)           _ -> pure ()         case rlHeaders of           Just (bs, bk) ->@@ -348,7 +349,7 @@       P.embed . atomically $ do         case rl of           KnownRatelimit bucket ->-            modifyTVar' (bucket ^. #state) (#ongoing -~ 1)+            modifyTVar' (bucket ^. #state) (#ongoing %~ succ)           _ -> pure ()         void $ updateBucket rlstate (routeKey route) bk bs @@ -360,7 +361,7 @@       debug "Internal error (ratelimited but no headers), retrying"       case rl of         KnownRatelimit bucket ->-          void . P.embed . atomically $ modifyTVar' (bucket ^. #state) (#ongoing -~ 1)+          void . P.embed . atomically $ modifyTVar' (bucket ^. #state) (#ongoing %~ succ)         _ -> pure ()        P.embed $ threadDelayUntil unlockWhen@@ -372,7 +373,7 @@         atomically $ do           case rl of             KnownRatelimit bucket ->-              modifyTVar' (bucket ^. #state) (#ongoing -~ 1)+              modifyTVar' (bucket ^. #state) (#ongoing %~ pred)             _ -> pure ()           case bs of             Just (bs', bk) ->@@ -403,7 +404,7 @@         KnownRatelimit bucket ->           P.embed $ useBucketOnce bucket         _ -> debug "unknown ratelimit"-      pure $ RFail (HTTPError c $ decode v)+      pure $ RFail (HTTPError c $ Aeson.decode v)  doRequest :: P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r => RateLimitState -> Route -> IO LbsResponse -> Sem r (Either RestError LB.ByteString) doRequest rlstate route action =

@@ -23,7 +23,6 @@ import Calamity.Types.LogEff (LogEff) import Calamity.Types.Token import Calamity.Types.TokenEff-import Control.Lens import Control.Monad import Data.Aeson hiding (Options) import Data.Aeson.Types (parseEither)@@ -32,6 +31,7 @@ import qualified Data.Text.Encoding as TS import DiPolysemy hiding (debug, error, info) import Network.HTTP.Req+import Optics import qualified Polysemy as P import qualified Polysemy.Error as P import Web.HttpApiData

@@ -1,50 +1,50 @@--- | The route type--- Why I did this I don't know+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} -module Calamity.HTTP.Internal.Route-    ( mkRouteBuilder-    , giveID-    , giveParam-    , buildRoute-    , routeKey-    , RouteKey-    , RouteBuilder-    , RouteRequirement-    , Route(path)-    , S(..)-    , PS(..)-    , ID(..)-    , RouteFragmentable(..) ) where--import           Calamity.Types.Model.Channel-import           Calamity.Types.Model.Guild-import           Calamity.Types.Snowflake--import           Data.Hashable-import           Data.Kind-import           Data.Maybe                   ( fromJust )-import           Data.Text                    ( Text )-import qualified Data.Text                    as T-import           Data.Typeable-import           Data.Word-import           Data.List ( foldl' )--import           Network.HTTP.Req--import           GHC.Generics                 hiding ( S )+{- | The route type+ Why I did this I don't know+-}+module Calamity.HTTP.Internal.Route (+  mkRouteBuilder,+  giveID,+  giveParam,+  buildRoute,+  routeKey,+  RouteKey,+  RouteBuilder,+  RouteRequirement,+  Route (path),+  S (..),+  PS (..),+  ID (..),+  RouteFragmentable (..),+) where -import           TextShow-import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)+import Calamity.Types.Model.Channel+import Calamity.Types.Model.Guild+import Calamity.Types.Snowflake+import Data.Hashable+import Data.Kind+import Data.List (foldl')+import Data.Maybe (fromJust)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Typeable+import Data.Word+import GHC.Generics (Generic)+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import Network.HTTP.Req+import Optics.TH+import qualified TextShow  data RouteFragment-  = S' Text-    -- ^ Static string fragment-  | PS' String-    -- ^ Parameterised string fragment-  | ID' TypeRep-    -- ^ ID fragment-  deriving ( Generic, Show, Eq )+  = -- | Static string fragment+    S' Text+  | -- | Parameterised string fragment+    PS' String+  | -- | ID fragment+    ID' TypeRep+  deriving (Generic, Show, Eq)  -- | A static string fragment of a route newtype S = S Text@@ -61,7 +61,7 @@   = NotNeeded   | Required   | Satisfied-  deriving ( Generic, Show, Eq )+  deriving (Show, Eq)  data RequirementType   = IDRequirement Type@@ -69,62 +69,62 @@  data RouteBuilder (reqstate :: [(RequirementType, RouteRequirement)]) = UnsafeMkRouteBuilder   { route :: [RouteFragment]-  , ids   :: [(TypeRep, Word64)]+  , ids :: [(TypeRep, Word64)]   , params :: [(String, Text)]   }  mkRouteBuilder :: RouteBuilder '[] mkRouteBuilder = UnsafeMkRouteBuilder [] [] [] -giveID-  :: forall t reqs-   . Typeable t-  => Snowflake t-  -> RouteBuilder reqs-  -> RouteBuilder ('( 'IDRequirement t, 'Satisfied) ': reqs)+giveID ::+  forall t reqs.+  Typeable t =>+  Snowflake t ->+  RouteBuilder reqs ->+  RouteBuilder ('( 'IDRequirement t, 'Satisfied) ': reqs) giveID (Snowflake id) (UnsafeMkRouteBuilder route ids params) =   UnsafeMkRouteBuilder route ((typeRep $ Proxy @t, id) : ids) params -giveParam-  :: forall (s :: Symbol) reqs-   . KnownSymbol s-  => Text-  -> RouteBuilder reqs-  -> RouteBuilder ('( 'PSRequirement s, 'Satisfied) ': reqs)+giveParam ::+  forall (s :: Symbol) reqs.+  KnownSymbol s =>+  Text ->+  RouteBuilder reqs ->+  RouteBuilder ('( 'PSRequirement s, 'Satisfied) ': reqs) giveParam value (UnsafeMkRouteBuilder route ids params) =   UnsafeMkRouteBuilder route ids ((symbolVal $ Proxy @s, value) : params)  type family (&&) (a :: Bool) (b :: Bool) :: Bool where   'True && 'True = 'True-  _     && _     = 'False+  _ && _ = 'False  type family Lookup (x :: k) (l :: [(k, v)]) :: Maybe v where   Lookup k ('(k, v) ': xs) = 'Just v   Lookup k ('(_, v) ': xs) = Lookup k xs-  Lookup _ '[]             = 'Nothing+  Lookup _ '[] = 'Nothing  type family IsElem (x :: k) (l :: [k]) :: Bool where-  IsElem _ '[]      = 'False-  IsElem k (k : _)  = 'True+  IsElem _ '[] = 'False+  IsElem k (k : _) = 'True   IsElem k (_ : xs) = IsElem k xs  type family EnsureFulfilled (reqs :: [(RequirementType, RouteRequirement)]) :: Constraint where   EnsureFulfilled reqs = EnsureFulfilledInner reqs '[] 'True  type family EnsureFulfilledInner (reqs :: [(RequirementType, RouteRequirement)]) (seen :: [RequirementType]) (ok :: Bool) :: Constraint where-  EnsureFulfilledInner '[]                      _    'True = ()-  EnsureFulfilledInner ('(k, 'NotNeeded) ': xs) seen ok    = EnsureFulfilledInner xs (k ': seen) ok-  EnsureFulfilledInner ('(k, 'Satisfied) ': xs) seen ok    = EnsureFulfilledInner xs (k ': seen) ok-  EnsureFulfilledInner ('(k, 'Required)  ': xs) seen ok    = EnsureFulfilledInner xs (k ': seen) (IsElem k seen && ok)+  EnsureFulfilledInner '[] _ 'True = ()+  EnsureFulfilledInner ('(k, 'NotNeeded) ': xs) seen ok = EnsureFulfilledInner xs (k ': seen) ok+  EnsureFulfilledInner ('(k, 'Satisfied) ': xs) seen ok = EnsureFulfilledInner xs (k ': seen) ok+  EnsureFulfilledInner ('(k, 'Required) ': xs) seen ok = EnsureFulfilledInner xs (k ': seen) (IsElem k seen && ok)  type family AddRequired k (reqs :: [(RequirementType, RouteRequirement)]) :: [(RequirementType, RouteRequirement)] where   AddRequired k reqs = '(k, AddRequiredInner (Lookup k reqs)) ': reqs  type family AddRequiredInner (k :: Maybe RouteRequirement) :: RouteRequirement where-  AddRequiredInner ('Just 'Required)  = 'Required-  AddRequiredInner ('Just 'Satisfied) = 'Satisfied-  AddRequiredInner ('Just 'NotNeeded) = 'Required-  AddRequiredInner 'Nothing           = 'Required+  AddRequiredInner ( 'Just 'Required) = 'Required+  AddRequiredInner ( 'Just 'Satisfied) = 'Satisfied+  AddRequiredInner ( 'Just 'NotNeeded) = 'Required+  AddRequiredInner 'Nothing = 'Required  class Typeable a => RouteFragmentable a reqs where   type ConsRes a reqs@@ -138,26 +138,26 @@     UnsafeMkRouteBuilder (r <> [S' t]) ids params  instance Typeable a => RouteFragmentable (ID (a :: Type)) (reqs :: [(RequirementType, RouteRequirement)]) where-  type ConsRes (ID a) reqs = RouteBuilder (AddRequired ('IDRequirement a) reqs)+  type ConsRes (ID a) reqs = RouteBuilder (AddRequired ( 'IDRequirement a) reqs)    (UnsafeMkRouteBuilder r ids params) // ID =     UnsafeMkRouteBuilder (r <> [ID' $ typeRep $ Proxy @a]) ids params  instance KnownSymbol s => RouteFragmentable (PS s) (reqs :: [(RequirementType, RouteRequirement)]) where-  type ConsRes (PS s) reqs = RouteBuilder (AddRequired ('PSRequirement s) reqs)+  type ConsRes (PS s) reqs = RouteBuilder (AddRequired ( 'PSRequirement s) reqs)    (UnsafeMkRouteBuilder r ids params) // PS =     UnsafeMkRouteBuilder (r <> [PS' $ symbolVal $ Proxy @s]) ids params - infixl 5 //  data Route = Route-  { path      :: Url 'Https-  , key       :: Text+  { path :: Url 'Https+  , key :: Text   , channelID :: Maybe (Snowflake Channel)-  , guildID   :: Maybe (Snowflake Guild)-  } deriving (Generic, Show)+  , guildID :: Maybe (Snowflake Guild)+  }+  deriving (Show)  type RouteKey = (Text, Maybe (Snowflake Channel), Maybe (Snowflake Guild)) @@ -167,21 +167,24 @@ baseURL :: Url 'Https baseURL = https "discord.com" /: "api" /: "v10" -buildRoute-  :: forall (reqs :: [(RequirementType, RouteRequirement)])-   . EnsureFulfilled reqs-  => RouteBuilder reqs-  -> Route-buildRoute (UnsafeMkRouteBuilder route ids params) = Route-  (foldl' (/:) baseURL $ map goR route)-  (T.concat (map goIdent route))-  (Snowflake <$> lookup (typeRep (Proxy @Channel)) ids)-  (Snowflake <$> lookup (typeRep (Proxy @Guild)) ids)- where-  goR (S'  t) = t-  goR (PS' t) = fromJust $ lookup t params-  goR (ID' t) = showt . fromJust $ lookup t ids+buildRoute ::+  forall (reqs :: [(RequirementType, RouteRequirement)]).+  EnsureFulfilled reqs =>+  RouteBuilder reqs ->+  Route+buildRoute (UnsafeMkRouteBuilder route ids params) =+  Route+    (foldl' (/:) baseURL $ map goR route)+    (T.concat (map goIdent route))+    (Snowflake <$> lookup (typeRep (Proxy @Channel)) ids)+    (Snowflake <$> lookup (typeRep (Proxy @Guild)) ids)+  where+    goR (S' t) = t+    goR (PS' t) = fromJust $ lookup t params+    goR (ID' t) = TextShow.showt . fromJust $ lookup t ids -  goIdent (S'  t) = t-  goIdent (PS' s) = T.pack s-  goIdent (ID' t) = showt t+    goIdent (S' t) = t+    goIdent (PS' s) = T.pack s+    goIdent (ID' t) = TextShow.showt t++$(makeFieldLabelsNoPrefix ''Route)

@@ -1,3 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+ -- | Types for the http lib module Calamity.HTTP.Internal.Types     ( RestError(..)@@ -8,8 +10,7 @@     , GatewayResponse     , BotGatewayResponse ) where -import           Calamity.HTTP.Internal.Route-import           Calamity.Internal.AesonThings+import Calamity.HTTP.Internal.Route import           Control.Concurrent.Event      ( Event ) import           Control.Concurrent.STM.TVar   ( TVar ) import Data.Time@@ -17,8 +18,9 @@ import qualified Data.ByteString.Lazy          as LB import qualified Data.ByteString          as B import           Data.Text as T-import           GHC.Generics import qualified StmContainers.Map             as SC+import qualified Data.Aeson as Aeson+import Optics.TH  data RestError   -- | An error response from discord@@ -28,7 +30,7 @@       }   -- | Something failed while making the request (after retrying a few times)   | InternalClientError T.Text-  deriving ( Show, Generic )+  deriving ( Show)  data BucketState = BucketState   { resetTime :: Maybe UTCTime@@ -42,19 +44,17 @@   , ongoing :: Int     -- ^ How many ongoing requests   }-  deriving ( Generic, Show )+  deriving ( Show )  newtype Bucket = Bucket   { state :: TVar BucketState   }-  deriving ( Generic )  data RateLimitState = RateLimitState   { bucketKeys :: SC.Map RouteKey B.ByteString   , buckets    :: SC.Map B.ByteString Bucket   , globalLock :: Event   }-  deriving ( Generic )  data DiscordResponseType   = Good@@ -76,12 +76,26 @@ newtype GatewayResponse = GatewayResponse   { url :: T.Text   }-  deriving ( Generic, Show )-  deriving ( FromJSON ) via CalamityJSON GatewayResponse+  deriving stock ( Show ) +instance Aeson.FromJSON GatewayResponse where+  parseJSON = Aeson.withObject "GatewayResponse" $ \v ->+    GatewayResponse <$> v .: "url"+ data BotGatewayResponse = BotGatewayResponse   { url    :: T.Text   , shards :: Int   }-  deriving ( Generic, Show )-  deriving ( FromJSON ) via CalamityJSON BotGatewayResponse+  deriving ( Show )++instance Aeson.FromJSON BotGatewayResponse where+  parseJSON = Aeson.withObject "BotGatewayResponse" $ \v ->+    BotGatewayResponse+      <$> v .: "url"+      <*> v .: "shards"++$(makeFieldLabelsNoPrefix ''Bucket)+$(makeFieldLabelsNoPrefix ''BucketState)+$(makeFieldLabelsNoPrefix ''RateLimitState)+$(makeFieldLabelsNoPrefix ''GatewayResponse)+$(makeFieldLabelsNoPrefix ''BotGatewayResponse)

@@ -4,11 +4,8 @@ import Calamity.HTTP.Internal.Request import Calamity.HTTP.Internal.Route import Calamity.Types.Model.Guild--import Control.Lens hiding ((.=))-+import Data.Function ((&)) import Data.Text (Text)- import Network.HTTP.Req  data InviteRequest a where

@@ -4,8 +4,7 @@ import Calamity.HTTP.Internal.Request import Calamity.HTTP.Internal.Route import Calamity.HTTP.Internal.Types--import Data.Function+import Data.Function ((&))  data MiscRequest a where   GetGateway :: MiscRequest GatewayResponse

@@ -5,16 +5,12 @@ ) where  import Calamity.HTTP.Internal.Request- import Data.Text (Text) import Data.Text.Encoding (encodeUtf8)--import GHC.Generics- import Network.HTTP.Req  data Reason a = Reason a Text-  deriving (Show, Eq, Generic)+  deriving (Show, Eq)  -- | Attach a reason to a request reason :: Request a => Text -> a -> Reason a

@@ -1,3 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+ -- | User endpoints module Calamity.HTTP.User (   UserRequest (..),@@ -7,20 +9,16 @@  import Calamity.HTTP.Internal.Request import Calamity.HTTP.Internal.Route-import Calamity.Internal.AesonThings+import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.?=)) import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild import Calamity.Types.Model.User import Calamity.Types.Snowflake--import Control.Lens hiding ((.=))--import Data.Aeson+import qualified Data.Aeson as Aeson import Data.Default.Class+import Data.Function ((&)) import Data.Text (Text)--import GHC.Generics-+import Optics.TH import Network.HTTP.Req  data ModifyUserData = ModifyUserData@@ -28,16 +26,28 @@   , -- | The avatar field should be in discord's image data format: https://discord.com/developers/docs/reference#image-data     avatar :: Maybe Text   }-  deriving (Show, Generic, Default)-  deriving (ToJSON) via CalamityJSON ModifyUserData+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON ModifyUserData +instance CalamityToJSON' ModifyUserData where+  toPairs ModifyUserData {..} =+    [ "username" .?= username+    , "avatar" .?= avatar+    ]++instance Default ModifyUserData where+  def = ModifyUserData Nothing Nothing+ data GetCurrentUserGuildsOptions = GetCurrentUserGuildsOptions   { before :: Maybe (Snowflake Guild)   , after :: Maybe (Snowflake Guild)   , limit :: Maybe Integer   }-  deriving (Show, Generic, Default)+  deriving (Show) +instance Default GetCurrentUserGuildsOptions where+  def = GetCurrentUserGuildsOptions Nothing Nothing Nothing+ data UserRequest a where   GetCurrentUser :: UserRequest User   GetUser :: HasID User u => u -> UserRequest User@@ -76,10 +86,13 @@   action GetCurrentUser = getWith   action (GetUser _) = getWith   action (ModifyCurrentUser o) = patchWith' $ ReqBodyJson o-  action (GetCurrentUserGuilds GetCurrentUserGuildsOptions{before, after, limit}) =+  action (GetCurrentUserGuilds GetCurrentUserGuildsOptions {before, after, limit}) =     getWithP       ( "before" =:? (fromSnowflake <$> before) <> "after" =:? (fromSnowflake <$> after)           <> "limit" =:? limit       )   action (LeaveGuild _) = deleteWith-  action (CreateDM (getID @User -> uid)) = postWith' $ ReqBodyJson (object ["recipient_id" .= uid])+  action (CreateDM (getID @User -> uid)) = postWith' $ ReqBodyJson (Aeson.object ["recipient_id" Aeson..= uid])++$(makeFieldLabelsNoPrefix ''ModifyUserData)+$(makeFieldLabelsNoPrefix ''GetCurrentUserGuildsOptions)

@@ -1,3 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+ -- | Webhook endpoints module Calamity.HTTP.Webhook (   WebhookRequest (..),@@ -9,19 +11,18 @@ import Calamity.HTTP.Channel (AllowedMentions, CreateMessageAttachment (..)) import Calamity.HTTP.Internal.Request import Calamity.HTTP.Internal.Route-import Calamity.Internal.AesonThings+import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=)) import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild import Calamity.Types.Snowflake-import Control.Lens hiding ((.=))-import Data.Aeson+import qualified Data.Aeson as Aeson import Data.Default.Class import Data.Text (Text) import qualified Data.Text as T-import GHC.Generics import Network.HTTP.Client.MultipartFormData import Network.HTTP.Req import Network.Mime+import Optics import PyF  data CreateWebhookData = CreateWebhookData@@ -29,18 +30,37 @@   , -- | The avatar field should be in discord's image data format: https://discord.com/developers/docs/reference#image-data     avatar :: Maybe Text   }-  deriving (Show, Generic, Default)-  deriving (ToJSON) via CalamityJSON CreateWebhookData+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON CreateWebhookData +instance CalamityToJSON' CreateWebhookData where+  toPairs CreateWebhookData {..} =+    [ "username" .?= username+    , "avatar" .?= avatar+    ]++instance Default CreateWebhookData where+  def = CreateWebhookData Nothing Nothing+ data ModifyWebhookData = ModifyWebhookData   { username :: Maybe Text   , -- | The avatar field should be in discord's image data format: https://discord.com/developers/docs/reference#image-data     avatar :: Maybe Text   , channelID :: Maybe (Snowflake Channel)   }-  deriving (Show, Generic, Default)-  deriving (ToJSON) via CalamityJSON ModifyWebhookData+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON ModifyWebhookData +instance CalamityToJSON' ModifyWebhookData where+  toPairs ModifyWebhookData {..} =+    [ "username" .?= username+    , "avatar" .?= avatar+    , "channel_id" .?= channelID+    ]++instance Default ModifyWebhookData where+  def = ModifyWebhookData Nothing Nothing Nothing+ data ExecuteWebhookOptions = ExecuteWebhookOptions   { wait :: Maybe Bool   , content :: Maybe Text@@ -52,16 +72,26 @@   , tts :: Maybe Bool   , components :: [Component]   }-  deriving (Show, Generic, Default)+  deriving (Show) +instance Default ExecuteWebhookOptions where+  def = ExecuteWebhookOptions Nothing Nothing [] Nothing Nothing Nothing Nothing Nothing []+ data CreateMessageAttachmentJson = CreateMessageAttachmentJson   { id :: Int   , filename :: Text   , description :: Maybe Text   }-  deriving (Show, Generic)-  deriving (ToJSON) via CalamityJSON CreateMessageAttachmentJson+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON CreateMessageAttachmentJson +instance CalamityToJSON' CreateMessageAttachmentJson where+  toPairs CreateMessageAttachmentJson {..} =+    [ "id" .= id+    , "filename" .= filename+    , "description" .?= description+    ]+ data ExecuteWebhookJson = ExecuteWebhookJson   { content :: Maybe Text   , embeds :: Maybe [Embed]@@ -72,9 +102,24 @@   , allowedMentions :: Maybe AllowedMentions   , components :: [Component]   }-  deriving (Show, Generic)-  deriving (ToJSON) via CalamityJSON ExecuteWebhookJson+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON ExecuteWebhookJson +instance CalamityToJSON' ExecuteWebhookJson where+  toPairs ExecuteWebhookJson {..} =+    [ "content" .?= content+    , "embeds" .?= embeds+    , "avatar_url" .?= avatarUrl+    , "tts" .?= tts+    , "attachments" .= attachments+    , "allowed_mentions" .?= allowedMentions+    , "components" .= components+    ]++$(makeFieldLabelsNoPrefix ''CreateWebhookData)+$(makeFieldLabelsNoPrefix ''ModifyWebhookData)+$(makeFieldLabelsNoPrefix ''ExecuteWebhookOptions)+ data WebhookRequest a where   CreateWebhook :: HasID Channel c => c -> CreateWebhookData -> WebhookRequest Webhook   GetChannelWebhooks :: HasID Channel c => c -> WebhookRequest [Webhook]@@ -157,5 +202,5 @@             , components = wh ^. #components             , attachments = attachments             }-    body <- reqBodyMultipart (partLBS "payload_json" (encode jsonBody) : files)+    body <- reqBodyMultipart (partLBS "payload_json" (Aeson.encode jsonBody) : files)     postWithP' body ("wait" =:? (wh ^. #wait)) u o

@@ -14,7 +14,7 @@ import Calamity.Types.Model.User (User) import Calamity.Types.Snowflake import Control.Applicative ((<|>))-import Control.Lens ((^.), (^?), _Just)+import Optics ((^.), (^?), _Just, (%)) import Data.Maybe (fromJust) import Polysemy import qualified Polysemy as P@@ -36,7 +36,7 @@ getInteractionUser :: P.Member InteractionEff r => P.Sem r (Snowflake User) getInteractionUser = do   int <- getInteraction-  let uid = int ^? #user . _Just . #id-      mid = int ^? #member . _Just . #id+  let uid = int ^? #user % _Just % #id+      mid = int ^? #member % _Just % #id   pure . fromJust $ uid <|> mid 

@@ -20,7 +20,7 @@ import Calamity.Types.Model.User (User) import Calamity.Types.Snowflake (Snowflake) import Calamity.Types.Tellable-import Control.Lens ((^.))+import Optics import qualified Data.HashMap.Strict as H import Data.Text (Text) import qualified Polysemy as P

@@ -25,7 +25,6 @@ import Calamity.HTTP.Internal.Ratelimit (RatelimitEff) import Calamity.HTTP.Internal.Request (invoke) import Calamity.Interactions.Eff (InteractionEff (..))-import Calamity.Internal.AesonThings import Calamity.Metrics.Eff (MetricEff) import Calamity.Types.LogEff (LogEff) import Calamity.Types.Model.Channel.Component (CustomID)@@ -34,19 +33,19 @@ import Calamity.Types.Model.Interaction import Calamity.Types.TokenEff (TokenEff) import qualified Control.Concurrent.STM as STM-import Control.Lens ((.~), (?~), (^.), (^..), _1, _2, _3, _Just)+import Optics import Control.Monad (guard, void)-import qualified Data.Aeson-import Data.Aeson.Lens (AsValue (_Array), key)+import qualified Data.Aeson as Aeson import qualified Data.List import qualified Data.Set as S import Data.Text (Text)-import GHC.Generics (Generic) import qualified GHC.TypeLits as E import qualified Polysemy as P import qualified Polysemy.Resource as P import qualified Polysemy.State as P import System.Random+import Data.Aeson ((.:?), (.:))+import Data.Aeson.Optics  data ViewComponent a = ViewComponent   { component :: C.Component@@ -213,12 +212,12 @@ select' opts f = SingView $ \g ->   let (cid, g') = uniform g       comp = f $ C.select opts cid-      finalValues = S.fromList $ comp ^.. #options . traverse . #value+      finalValues = S.fromList $ comp ^.. #options % traversed % #value       parse int = extractOkFromMaybe $ do         customID <- extractCustomID int         guard $ customID == cid         guardComponentType int C.SelectType-        values <- int ^. #data_ . _Just . #values+        values <- int ^? #data_ % _Just % #values % _Just         let values' = S.fromList values         guard $ S.isSubsetOf values' finalValues         pure values@@ -228,20 +227,27 @@   { value :: Maybe Text   , customID :: CustomID   }-  deriving (Show, Generic)-  deriving (Data.Aeson.FromJSON) via CalamityJSON TextInputDecoded+  deriving (Show) +$(makeFieldLabelsNoPrefix ''TextInputDecoded)++instance Aeson.FromJSON TextInputDecoded where+  parseJSON = Aeson.withObject "TextInputDecoded" $ \v ->+    TextInputDecoded+      <$> v .:? "value"+      <*> v .: "custom_id"+ parseTextInput :: CustomID -> Interaction -> ExtractResult (Maybe Text) parseTextInput cid int = extractOkFromMaybe $ do-  components <- int ^. #data_ . _Just . #components+  components <- int ^? #data_ % _Just % #components   -- currently, each text input is a singleton actionrow containing a single textinput component -  let textInputs = components ^.. traverse . key "components" . _Array . traverse-      inputs' :: Data.Aeson.Result [TextInputDecoded] = traverse Data.Aeson.fromJSON textInputs+  let textInputs = components ^.. traversed % traversed % key "components" % _Array % traversed+      inputs' :: Aeson.Result [TextInputDecoded] = traverse Aeson.fromJSON textInputs    inputs <- case inputs' of-    Data.Aeson.Success x -> pure x-    Data.Aeson.Error _ -> Nothing+    Aeson.Success x -> pure x+    Aeson.Error _ -> Nothing    thisValue <- Data.List.find ((== cid) . (^. #customID)) inputs 

@@ -1,159 +0,0 @@-module Calamity.Internal.AesonThings (-  WithSpecialCases (..),-  IfNoneThen,-  ExtractFieldFrom,-  ExtractFieldInto,-  ExtractFields,-  ExtractArrayField,-  DefaultToEmptyArray,-  DefaultToZero,-  DefaultToFalse,-  DefaultToTrue,-  CalamityJSON (..),-  CalamityJSONKeepNothing (..),-  jsonOptions,-  jsonOptionsKeepNothing,-) where--import Control.Lens--import Data.Aeson-import Data.Aeson.Lens-import Data.Aeson.Types (Parser)-import Data.Kind-import Data.Reflection (Reifies (..))-import Data.String (IsString (fromString))-import Data.Typeable--import Control.Monad ((>=>))-import GHC.Generics-import GHC.TypeLits (KnownSymbol, symbolVal)--textSymbolVal :: forall n s. (KnownSymbol n, IsString s) => s-textSymbolVal = fromString $ symbolVal @n Proxy--data IfNoneThen label def-data ExtractFieldInto label field target-type ExtractFieldFrom label field = ExtractFieldInto label field label-data ExtractFields label fields-data ExtractArrayField label field-data MapFieldWith field ty--class PerformAction action where-  runAction :: Proxy action -> Object -> Parser Object--instance (Reifies d Value, KnownSymbol label) => PerformAction (IfNoneThen label d) where-  runAction _ o = do-    v <- o .:? textSymbolVal @label .!= reflect @d Proxy-    pure $ o & at (textSymbolVal @label) ?~ v--instance (KnownSymbol label, KnownSymbol field, KnownSymbol target) => PerformAction (ExtractFieldInto label field target) where-  runAction _ o =-    let v :: Maybe Value = o ^? ix (textSymbolVal @label) . _Object . ix (textSymbolVal @field)-     in pure $ o & at (textSymbolVal @target) .~ v--instance PerformAction (ExtractFields label '[]) where-  runAction _ = pure--instance-  ( KnownSymbol field-  , PerformAction (ExtractFieldInto label field field)-  , PerformAction (ExtractFields label fields)-  ) =>-  PerformAction (ExtractFields label (field : fields))-  where-  runAction _ = runAction (Proxy @(ExtractFieldInto label field field)) >=> runAction (Proxy @(ExtractFields label fields))--instance (KnownSymbol label, KnownSymbol field) => PerformAction (ExtractArrayField label field) where-  runAction _ o = do-    a :: Maybe Array <- o .:? textSymbolVal @label-    case a of-      Just a' -> do-        a'' <- Array <$> traverse (withObject "extracting field" (.: textSymbolVal @field)) a'-        pure $ o & at (textSymbolVal @label) ?~ a''-      Nothing -> pure o--instance (KnownSymbol field, Reifies ty (Value -> Value)) => PerformAction (MapFieldWith field ty) where-  runAction _ o = pure (o & ix (textSymbolVal @field) %~ reflect @ty Proxy)--newtype WithSpecialCases (rules :: [Type]) a = WithSpecialCases a--class RunSpecialCase a where-  runSpecialCases :: Proxy a -> Object -> Parser Object--instance RunSpecialCase '[] where-  runSpecialCases _ = pure--instance (RunSpecialCase xs, PerformAction action) => RunSpecialCase (action : xs) where-  runSpecialCases _ o = do-    o' <- runSpecialCases (Proxy @xs) o-    runAction (Proxy @action) o'--instance-  (RunSpecialCase rules, Typeable a, Generic a, GFromJSON Zero (Rep a)) =>-  FromJSON (WithSpecialCases rules a)-  where-  parseJSON = withObject (show . typeRep $ Proxy @a) $ \o -> do-    o' <- runSpecialCases (Proxy @rules) o-    WithSpecialCases <$> genericParseJSON jsonOptions (Object o')--data DefaultToEmptyArray--instance Reifies DefaultToEmptyArray Value where-  reflect _ = Array mempty--data DefaultToZero--instance Reifies DefaultToZero Value where-  reflect _ = Number 0--data DefaultToFalse--instance Reifies DefaultToFalse Value where-  reflect _ = Bool False--data DefaultToTrue--instance Reifies DefaultToTrue Value where-  reflect _ = Bool True--newtype CalamityJSON a = CalamityJSON-  { unCalamityJSON :: a-  }--instance (Typeable a, Generic a, GToJSON Zero (Rep a), GToEncoding Zero (Rep a)) => ToJSON (CalamityJSON a) where-  toJSON = genericToJSON jsonOptions . unCalamityJSON--  toEncoding = genericToEncoding jsonOptions . unCalamityJSON--instance (Typeable a, Generic a, GFromJSON Zero (Rep a)) => FromJSON (CalamityJSON a) where-  parseJSON = fmap CalamityJSON . genericParseJSON jsonOptions---- | version that keeps Nothing fields-newtype CalamityJSONKeepNothing a = CalamityJSONKeepNothing-  { unCalamityJSONKeepNothing :: a-  }--instance (Typeable a, Generic a, GToJSON Zero (Rep a), GToEncoding Zero (Rep a)) => ToJSON (CalamityJSONKeepNothing a) where-  toJSON = genericToJSON jsonOptionsKeepNothing . unCalamityJSONKeepNothing--  toEncoding = genericToEncoding jsonOptionsKeepNothing . unCalamityJSONKeepNothing--instance (Typeable a, Generic a, GFromJSON Zero (Rep a)) => FromJSON (CalamityJSONKeepNothing a) where-  parseJSON = fmap CalamityJSONKeepNothing . genericParseJSON jsonOptionsKeepNothing--jsonOptions :: Options-jsonOptions =-  defaultOptions-    { sumEncoding = UntaggedValue-    , fieldLabelModifier = camelTo2 '_' . filter (/= '_')-    , omitNothingFields = True-    }--jsonOptionsKeepNothing :: Options-jsonOptionsKeepNothing =-  defaultOptions-    { sumEncoding = UntaggedValue-    , fieldLabelModifier = camelTo2 '_' . filter (/= '_')-    , omitNothingFields = False-    }

@@ -1,3 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+ -- | A thing for storing the last N things with IDs module Calamity.Internal.BoundedStore (   BoundedStore,@@ -7,17 +9,16 @@   dropItem, ) where -import Calamity.Internal.Utils-import Calamity.Types.Snowflake-import Control.Lens-import Control.Monad.State.Lazy-import Data.Default.Class-import Data.Generics.Labels ()+import Calamity.Internal.Utils ( unlessM, whenM )+import Calamity.Types.Snowflake ( HasID(getID), Snowflake, HasID' )+import Control.Monad.State.Lazy ( when, execState )+import Data.Default.Class ( Default(..) ) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as H import Deque.Lazy (Deque) import qualified Deque.Lazy as DQ-import GHC.Generics+import Optics+import Optics.State.Operators ((%=), (.=))  data BoundedStore a = BoundedStore   { itemQueue :: Deque (Snowflake a)@@ -25,8 +26,10 @@   , limit :: Int   , size :: Int   }-  deriving (Show, Generic)+  deriving (Show) +$(makeFieldLabelsNoPrefix ''BoundedStore)+ instance Foldable BoundedStore where   foldr f i = foldr f i . H.elems . items @@ -43,19 +46,18 @@ instance HasID' a => Ixed (BoundedStore a)  instance HasID' a => At (BoundedStore a) where-  at k f m =-    f mv <&> \case-      Nothing -> maybe m (const (dropItem k m)) mv-      Just v -> addItem v m-   where-    mv = getItem k m+  at k = lensVL $ \f m ->+    let mv = getItem k m+     in f mv <&> \case+          Nothing -> maybe m (const (dropItem k m)) mv+          Just v -> addItem v m   {-# INLINE at #-}  addItem :: HasID' a => a -> BoundedStore a -> BoundedStore a addItem m = execState $ do   unlessM (H.member (getID m) <$> use #items) $ do     #itemQueue %= DQ.cons (getID m)-    #size += 1+    #size %= succ    size <- use #size   limit <- use #limit@@ -65,7 +67,7 @@     let Just (rid, q') = DQ.unsnoc q     #itemQueue .= q'     #items %= sans rid-    #size -= 1+    #size %= pred    #items %= H.insert (getID m) m {-# INLINE addItem #-}@@ -77,7 +79,7 @@ dropItem :: Snowflake a -> BoundedStore a -> BoundedStore a dropItem id = execState $ do   whenM (H.member id <$> use #items) $ do-    #size -= 1+    #size %= pred    #itemQueue %= DQ.filter (/= id)   #items %= H.delete id

@@ -1,8 +1,8 @@ -- | An internal newtype for parsing colours module Calamity.Internal.IntColour (-    IntColour (..),-    colourToWord64,-    colourFromWord64,+  IntColour (..),+  colourToWord64,+  colourFromWord64, ) where  import Data.Aeson@@ -10,29 +10,29 @@ import Data.Colour import Data.Colour.SRGB (RGB (RGB), sRGB24, toSRGB24) import Data.Word (Word64)-import GHC.Generics import TextShow -newtype IntColour = IntColour (Colour Double)-    deriving stock (Generic)-    deriving (Show) via Colour Double-    deriving (TextShow) via FromStringShow (Colour Double)+newtype IntColour = IntColour+  { fromIntColour :: Colour Double+  }+  deriving (Show) via Colour Double+  deriving (TextShow) via FromStringShow (Colour Double)  colourToWord64 :: IntColour -> Word64 colourToWord64 (IntColour c) =-    let RGB r g b = toSRGB24 c-        i = (fromIntegral r `shiftL` 16) .|. (fromIntegral g `shiftL` 8) .|. fromIntegral b-     in i+  let RGB r g b = toSRGB24 c+      i = (fromIntegral r `shiftL` 16) .|. (fromIntegral g `shiftL` 8) .|. fromIntegral b+   in i  colourFromWord64 :: Word64 -> IntColour colourFromWord64 i =-    let r = (i `shiftR` 16) .&. 0xff-        g = (i `shiftR` 8) .&. 0xff-        b = i .&. 0xff-     in IntColour $ sRGB24 (fromIntegral r) (fromIntegral g) (fromIntegral b)+  let r = (i `shiftR` 16) .&. 0xff+      g = (i `shiftR` 8) .&. 0xff+      b = i .&. 0xff+   in IntColour $ sRGB24 (fromIntegral r) (fromIntegral g) (fromIntegral b)  instance ToJSON IntColour where-    toJSON = toJSON . colourToWord64+  toJSON = toJSON . colourToWord64  instance FromJSON IntColour where-    parseJSON v = colourFromWord64 <$> parseJSON v+  parseJSON v = colourFromWord64 <$> parseJSON v

@@ -1,36 +0,0 @@--- | Internal newtype that we can safely define orphans on-module Calamity.Internal.OverriddenVia (-    OverriddenVia (..),-) where--import Calamity.Internal.ShapeCoerce-import Data.Aeson.Types-import Data.Default.Class-import TextShow--{- | @a@: The type that is to be wrapped- @b@: The type to convert to and use the instance of--}-newtype OverriddenVia a b = OverriddenVia {unOverrideVia :: a}--instance (ShapeCoerce b a, Default b) => Default (OverriddenVia a b) where-    def = OverriddenVia $ shapeCoerce @b @a $ def--instance (ShapeCoerce a b, Show b) => Show (OverriddenVia a b) where-    showsPrec d (OverriddenVia x) = showsPrec d $ shapeCoerce @a @b x-    show (OverriddenVia x) = show $ shapeCoerce @a @b x-    showList xs = showList $ map (shapeCoerce @a @b . unOverrideVia) xs--instance (ShapeCoerce b a, FromJSON b) => FromJSON (OverriddenVia a b) where-    parseJSON v = OverriddenVia . shapeCoerce @b @a <$> parseJSON v-    parseJSONList v = map (OverriddenVia . shapeCoerce @b @a) <$> parseJSONList v--instance (ShapeCoerce a b, ToJSON b) => ToJSON (OverriddenVia a b) where-    toJSON = toJSON . shapeCoerce @a @b . unOverrideVia-    toEncoding = toEncoding . shapeCoerce @a @b . unOverrideVia--    toJSONList = toJSONList . map (shapeCoerce @a @b . unOverrideVia)-    toEncodingList = toEncodingList . map (shapeCoerce @a @b . unOverrideVia)--instance (ShapeCoerce a b, TextShow b) => TextShow (OverriddenVia a b) where-    showb = showb . shapeCoerce @a @b . unOverrideVia

@@ -1,37 +0,0 @@-{- | Something to coerce between two records with the same field names and- compatible field types--}-module Calamity.Internal.ShapeCoerce (-    shapeCoerce,-    ShapeCoerce,-    GShapeCoerce (..),-) where--import Data.Coerce (Coercible, coerce)-import GHC.Generics--type ShapeCoerce a b = (Generic a, Generic b, GShapeCoerce (Rep a) (Rep b))--shapeCoerce :: (Generic a, Generic b, GShapeCoerce (Rep a) (Rep b)) => a -> b-shapeCoerce = to . gshapeCoerce . from--class GShapeCoerce f g where-    gshapeCoerce :: f a -> g b--instance (GShapeCoerce fa ga, GShapeCoerce fb gb) => GShapeCoerce (fa :*: fb) (ga :*: gb) where-    gshapeCoerce (la :*: lb) = gshapeCoerce la :*: gshapeCoerce lb--instance GShapeCoerce f g => GShapeCoerce (M1 D da f) (M1 D db g) where-    gshapeCoerce (M1 a) = M1 (gshapeCoerce a)--instance GShapeCoerce f g => GShapeCoerce (M1 C da f) (M1 C db g) where-    gshapeCoerce (M1 a) = M1 (gshapeCoerce a)--instance GShapeCoerce f g => GShapeCoerce (S1 ( 'MetaSel ( 'Just name) fsu fss fl) f) (S1 ( 'MetaSel ( 'Just name') gsu gss gl) g) where-    gshapeCoerce (M1 a) = M1 (gshapeCoerce a)--instance GShapeCoerce f g => GShapeCoerce (S1 ( 'MetaSel 'Nothing fsu fss fl) f) (S1 ( 'MetaSel 'Nothing gsu gss gl) g) where-    gshapeCoerce (M1 a) = M1 (gshapeCoerce a)--instance Coercible a b => GShapeCoerce (Rec0 a) (Rec0 b) where-    gshapeCoerce (K1 a) = K1 $ coerce a

@@ -3,10 +3,6 @@  import Calamity.Internal.Utils () import Calamity.Types.Snowflake-import Control.DeepSeq-import Control.Lens.At-import Control.Lens.Iso-import Control.Lens.Wrapped import Data.Aeson (FromJSON (..), ToJSON (..), withArray) import Data.Data import qualified Data.Foldable as F@@ -14,17 +10,17 @@ import qualified Data.HashMap.Strict as SH import Data.Hashable import GHC.Exts (IsList)-import GHC.Generics+import Optics import TextShow import Unsafe.Coerce  newtype SnowflakeMap a = SnowflakeMap   { unSnowflakeMap :: HashMap (Snowflake a) a   }-  deriving stock (Generic, Eq, Data, Ord, Show)+  deriving stock (Eq, Data, Ord, Show)   deriving (TextShow) via FromStringShow (SnowflakeMap a)   deriving newtype (IsList, Semigroup, Monoid)-  deriving newtype (NFData, Hashable)+  deriving newtype (Hashable)  -- instance At (SnowflakeMap a) where --   at k f m = at (unSnowflakeMap k) f m@@ -38,30 +34,30 @@ instance Traversable SnowflakeMap where   traverse f = fmap (SnowflakeMap . coerceSnowflakeMap) . traverse f . unSnowflakeMap --- deriving instance NFData a => NFData (SnowflakeMap a)---- deriving instance Hashable a => Hashable (SnowflakeMap a)--instance Wrapped (SnowflakeMap a) where-  type Unwrapped (SnowflakeMap a) = HashMap (Snowflake a) a--  _Wrapped' = iso unSnowflakeMap SnowflakeMap- type instance Index (SnowflakeMap a) = Snowflake a  type instance IxValue (SnowflakeMap a) = a -instance SnowflakeMap a ~ t => Rewrapped (SnowflakeMap b) a+_SnowflakeMap ::+  ( Iso+      (SnowflakeMap a)+      (SnowflakeMap a1)+      (HashMap (Snowflake a) a)+      (HashMap (Snowflake a1) a1)+  )+_SnowflakeMap = iso unSnowflakeMap SnowflakeMap  instance Ixed (SnowflakeMap a) where-  ix i = _Wrapped . ix i+  ix i = _SnowflakeMap % ix i+  {-# INLINE ix #-}  instance At (SnowflakeMap a) where-  at i = _Wrapped . at i+  at i = _SnowflakeMap % at i+  {-# INLINE at #-} -over :: (HashMap (Snowflake a) a -> HashMap (Snowflake b) b) -> SnowflakeMap a -> SnowflakeMap b-over f = SnowflakeMap . f . unSnowflakeMap-{-# INLINEABLE over #-}+overSM :: (HashMap (Snowflake a) a -> HashMap (Snowflake b) b) -> SnowflakeMap a -> SnowflakeMap b+overSM f = SnowflakeMap . f . unSnowflakeMap+{-# INLINEABLE overSM #-}  -- SAFETY: 'Snowflake' always uses the underlying hash function (Word64) coerceSnowflakeMap :: HashMap (Snowflake a) v -> HashMap (Snowflake b) v@@ -103,27 +99,27 @@ infixl 9 !  insert :: HasID' a => a -> SnowflakeMap a -> SnowflakeMap a-insert v = over $ SH.insert (getID v) v+insert v = overSM $ SH.insert (getID v) v {-# INLINEABLE insert #-}  insertWith :: HasID' a => (a -> a -> a) -> a -> SnowflakeMap a -> SnowflakeMap a-insertWith f v = over $ SH.insertWith f (getID v) v+insertWith f v = overSM $ SH.insertWith f (getID v) v {-# INLINEABLE insertWith #-}  delete :: Snowflake a -> SnowflakeMap a -> SnowflakeMap a-delete k = over $ SH.delete k+delete k = overSM $ SH.delete k {-# INLINEABLE delete #-}  adjust :: (a -> a) -> Snowflake a -> SnowflakeMap a -> SnowflakeMap a-adjust f k = over $ SH.adjust f k+adjust f k = overSM $ SH.adjust f k {-# INLINEABLE adjust #-}  update :: (a -> Maybe a) -> Snowflake a -> SnowflakeMap a -> SnowflakeMap a-update f k = over $ SH.update f k+update f k = overSM $ SH.update f k {-# INLINEABLE update #-}  alter :: (Maybe a -> Maybe a) -> Snowflake a -> SnowflakeMap a -> SnowflakeMap a-alter f k = over $ SH.alter f k+alter f k = overSM $ SH.alter f k {-# INLINEABLE alter #-}  union :: SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a@@ -143,11 +139,11 @@ {-# INLINEABLE unions #-}  map :: (a1 -> a2) -> SnowflakeMap a1 -> SnowflakeMap a2-map f = over $ coerceSnowflakeMap . SH.map f+map f = overSM $ coerceSnowflakeMap . SH.map f {-# INLINEABLE map #-}  mapWithKey :: (Snowflake a1 -> a1 -> a2) -> SnowflakeMap a1 -> SnowflakeMap a2-mapWithKey f = over $ coerceSnowflakeMap . SH.mapWithKey f+mapWithKey f = overSM $ coerceSnowflakeMap . SH.mapWithKey f {-# INLINEABLE mapWithKey #-}  traverseWithKey :: Applicative f => (Snowflake a1 -> a1 -> f a2) -> SnowflakeMap a1 -> f (SnowflakeMap a2)@@ -191,19 +187,19 @@ {-# INLINEABLE foldrWithKey #-}  filter :: (a -> Bool) -> SnowflakeMap a -> SnowflakeMap a-filter f = over $ SH.filter f+filter f = overSM $ SH.filter f {-# INLINEABLE filter #-}  filterWithKey :: (Snowflake a -> a -> Bool) -> SnowflakeMap a -> SnowflakeMap a-filterWithKey f = over $ SH.filterWithKey f+filterWithKey f = overSM $ SH.filterWithKey f {-# INLINEABLE filterWithKey #-}  mapMaybe :: (a -> Maybe b) -> SnowflakeMap a -> SnowflakeMap b-mapMaybe f = over $ coerceSnowflakeMap . SH.mapMaybe f+mapMaybe f = overSM $ coerceSnowflakeMap . SH.mapMaybe f {-# INLINEABLE mapMaybe #-}  mapMaybeWithKey :: (Snowflake a -> a -> Maybe b) -> SnowflakeMap a -> SnowflakeMap b-mapMaybeWithKey f = over $ coerceSnowflakeMap . SH.mapMaybeWithKey f+mapMaybeWithKey f = overSM $ coerceSnowflakeMap . SH.mapMaybeWithKey f {-# INLINEABLE mapMaybeWithKey #-}  keys :: SnowflakeMap a -> [Snowflake a]

@@ -7,20 +7,16 @@  import Calamity.Internal.Utils () import Control.Arrow-import Control.DeepSeq (NFData) import Data.Aeson import Data.Aeson.Encoding (word64) import Data.Time import Data.Time.Clock.POSIX import Data.Word-import GHC.Generics import TextShow  newtype UnixTimestamp = UnixTimestamp     { unUnixTimestamp :: UTCTime     }-    deriving stock (Generic)-    deriving anyclass (NFData)     deriving (Show) via UTCTime     deriving (TextShow) via FromStringShow UTCTime 

@@ -6,67 +6,84 @@ 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+import Optics  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 ::+  forall (f :: Symbol) o n b k.+  ( k ~ A_Lens+  , LabelOptic' f k o b+  , LabelOptic' f k n b+  ) =>+  n ->+  o ->+  o+setF n = labelOptic @f .~ n ^. labelOptic @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)) => n -> o -> o-mergeF n = field' @f %~ \oldv -> fromMaybe oldv (n ^. field' @f)+mergeF ::+  forall (f :: Symbol) o n b k.+  ( k ~ A_Lens+  , LabelOptic' f k o b+  , LabelOptic' f k n (Maybe b)+  ) =>+  n ->+  o ->+  o+mergeF n = labelOptic @f %~ \oldv -> fromMaybe oldv (n ^. labelOptic @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)+  forall (f :: Symbol) old new v k.+  ( k ~ A_Lens+  , LabelOptic' f k old (Maybe v)+  , LabelOptic' f k new (Maybe v)+  ) =>+  new ->+  old ->+  old+mergeF' new = labelOptic @f %~ \oldv -> lastMaybe oldv (new ^. labelOptic @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+  forall (f :: Symbol) old new v k.+  ( k ~ A_Lens+  , LabelOptic' f k old (Maybe v)+  , LabelOptic' f k new (Maybe (MaybeNull v))+  ) =>+  new ->+  old ->+  old+updateNullableDest new = case new ^. labelOptic @f of+  Just (NotNull x) -> labelOptic @f ?~ x+  Just WasNull -> labelOptic @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+  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 @"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@@ -77,50 +94,50 @@       & 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 -    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+  update n o =+    o+      & setF @"name" n+      & setF @"icon" n+      & setF @"splash" n+      & setF @"owner" n+      & setF @"ownerID" n+      & mergeF @"permissions" 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+      & setF @"preferredLocale" n  instance Updateable User where-    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+  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

@@ -12,6 +12,8 @@   (<<$>>),   (<<*>>),   (<.>),+  (.?=),+  (.=),   debug,   info,   Calamity.Internal.Utils.error,@@ -20,13 +22,14 @@   AesonVector (..),   CalamityFromStringShow (..),   MaybeNull (..),+  CalamityToJSON (..),+  CalamityToJSON' (..), ) where  -- import Calamity.Internal.RunIntoIO import Calamity.Types.LogEff import Control.Applicative import Control.Monad (when)-import Data.Aeson import Data.Aeson.Encoding (null_) import Data.Default.Class import qualified Data.Map as M@@ -34,10 +37,10 @@ import Data.Text import qualified Data.Vector.Unboxing as VU import qualified DiPolysemy as Di-import GHC.Generics import qualified Polysemy as P import TextShow-import qualified TextShow.Generic as TSG+import qualified Data.Aeson as Aeson+import Data.Maybe (catMaybes)  {- | Like whileM, but stateful effects are not preserved to mitigate memory leaks @@ -137,18 +140,18 @@ newtype AesonVector a = AesonVector {unAesonVector :: VU.Vector a}   deriving (Show) via VU.Vector a -instance (FromJSON a, VU.Unboxable a) => FromJSON (AesonVector a) where-  parseJSON = (AesonVector . VU.fromList <$>) . parseJSON+instance (Aeson.FromJSON a, VU.Unboxable a) => Aeson.FromJSON (AesonVector a) where+  parseJSON = (AesonVector . VU.fromList <$>) . Aeson.parseJSON -instance (ToJSON a, VU.Unboxable a) => ToJSON (AesonVector a) where-  toJSON = toJSON . VU.toList . unAesonVector-  toEncoding = toEncoding . VU.toList . unAesonVector+instance (Aeson.ToJSON a, VU.Unboxable a) => Aeson.ToJSON (AesonVector a) where+  toJSON = Aeson.toJSON . VU.toList . unAesonVector+  toEncoding = Aeson.toEncoding . VU.toList . unAesonVector  instance (TextShow a, VU.Unboxable a) => TextShow (AesonVector a) where   showb = showbList . VU.toList . unAesonVector  newtype CalamityFromStringShow a = CalamityFromStringShow {unCalamityFromStringShow :: a}-  deriving (FromJSON, ToJSON) via a+  deriving (Aeson.FromJSON, Aeson.ToJSON) via a   deriving (TextShow) via FromStringShow a  {- | An alternative 'Maybe' type that allows us to distinguish between parsed@@ -157,16 +160,31 @@ data MaybeNull a   = WasNull   | NotNull a-  deriving (Show, Generic)-  deriving (TextShow) via TSG.FromGeneric (MaybeNull a)+  deriving (Show) -instance FromJSON a => FromJSON (MaybeNull a) where-  parseJSON Null = pure WasNull-  parseJSON x = NotNull <$> parseJSON x+instance Aeson.FromJSON a => Aeson.FromJSON (MaybeNull a) where+  parseJSON Aeson.Null = pure WasNull+  parseJSON x = NotNull <$> Aeson.parseJSON x -instance ToJSON a => ToJSON (MaybeNull a) where-  toJSON WasNull = Null-  toJSON (NotNull x) = toJSON x+instance Aeson.ToJSON a => Aeson.ToJSON (MaybeNull a) where+  toJSON WasNull = Aeson.Null+  toJSON (NotNull x) = Aeson.toJSON x    toEncoding WasNull = null_-  toEncoding (NotNull x) = toEncoding x+  toEncoding (NotNull x) = Aeson.toEncoding x++(.?=) :: (Aeson.ToJSON v, Aeson.KeyValue kv) => Aeson.Key -> Maybe v -> Maybe kv+k .?= Just v = Just (k Aeson..= v)+_ .?= Nothing = Nothing++(.=) :: (Aeson.ToJSON v, Aeson.KeyValue kv) => Aeson.Key -> v -> Maybe kv+k .= v = Just (k Aeson..= v)++class CalamityToJSON' a where+  toPairs :: Aeson.KeyValue kv => a -> [Maybe kv]++newtype CalamityToJSON a = CalamityToJSON a++instance CalamityToJSON' a => Aeson.ToJSON (CalamityToJSON a) where+  toJSON (CalamityToJSON x) = Aeson.object . catMaybes . toPairs $ x+  toEncoding (CalamityToJSON x) = Aeson.pairs . mconcat . catMaybes . toPairs $ x

@@ -15,35 +15,27 @@   observeHistogram, ) where -import Calamity.Internal.Utils (DefaultingMap) import Calamity.Metrics.Internal import Data.Default.Class-import Data.Map+import qualified Data.Map as Map import Data.Text-import GHC.Generics+import Optics.TH import Polysemy import TextShow-import Calamity.Internal.OverriddenVia -data HistogramSample' = HistogramSample'-  { buckets :: DefaultingMap Double Double-  , sum :: Double-  , count :: Int-  }-  deriving (Generic)-  deriving (Default)- data HistogramSample = HistogramSample-  { buckets :: Map Double Double+  { buckets :: Map.Map Double Double   , sum :: Double   , count :: Int   }-  deriving (Eq, Show, Generic)-  deriving (Default) via OverriddenVia HistogramSample HistogramSample+  deriving (Eq, Show)   deriving     (TextShow)     via FromStringShow HistogramSample +instance Default HistogramSample where+  def = HistogramSample Map.empty 0.0 0+ data MetricEff m a where   -- | Register a 'Counter'   RegisterCounter ::@@ -73,3 +65,5 @@   ObserveHistogram :: Double -> Histogram -> MetricEff m HistogramSample  makeSem ''MetricEff++$(makeFieldLabelsNoPrefix ''HistogramSample)

@@ -1,15 +1,16 @@ {-# LANGUAGE NoImplicitPrelude #-}  -- | The logging effect we use-module Calamity.Types.LogEff-    ( LogEff-    , LogC ) where+module Calamity.Types.LogEff (+  LogEff,+  LogC,+) where  import qualified Df1 -import           DiPolysemy+import DiPolysemy -import qualified Polysemy   as P+import qualified Polysemy as P  type LogEff = Di Df1.Level Df1.Path Df1.Message 

@@ -1,13 +1,14 @@ -- | Discord data models-module Calamity.Types.Model-    ( module Calamity.Types.Model.Channel-    , module Calamity.Types.Model.Guild-    , module Calamity.Types.Model.Presence-    , module Calamity.Types.Model.User-    , module Calamity.Types.Model.Voice ) where+module Calamity.Types.Model (+  module Calamity.Types.Model.Channel,+  module Calamity.Types.Model.Guild,+  module Calamity.Types.Model.Presence,+  module Calamity.Types.Model.User,+  module Calamity.Types.Model.Voice,+) where -import           Calamity.Types.Model.Channel-import           Calamity.Types.Model.Guild-import           Calamity.Types.Model.Presence-import           Calamity.Types.Model.User-import           Calamity.Types.Model.Voice+import Calamity.Types.Model.Channel+import Calamity.Types.Model.Guild+import Calamity.Types.Model.Presence+import Calamity.Types.Model.User+import Calamity.Types.Model.Voice

@@ -1,3 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+ -- | The generic channel type module Calamity.Types.Model.Channel (   Channel (..),@@ -14,7 +16,7 @@   module Calamity.Types.Model.Channel.Component, ) where -import Calamity.Internal.AesonThings+import Calamity.Internal.Utils import Calamity.Types.Model.Channel.Attachment import Calamity.Types.Model.Channel.ChannelType import Calamity.Types.Model.Channel.Component@@ -27,43 +29,71 @@ import Calamity.Types.Model.Channel.Webhook import Calamity.Types.Model.Guild.Permissions (Permissions) import Calamity.Types.Snowflake-import Data.Aeson+import Data.Aeson ((.:), (.:?))+import qualified Data.Aeson as Aeson import Data.Text (Text)-import GHC.Generics-import TextShow-import qualified TextShow.Generic as TSG+import Optics.TH+import TextShow.TH  data Channel   = DMChannel' DMChannel   | GroupChannel' GroupChannel   | GuildChannel' GuildChannel-  deriving (Show, Eq, Generic)-  deriving (TextShow) via TSG.FromGeneric Channel+  deriving (Show, Eq)  instance HasID Channel Channel where   getID (DMChannel' a) = getID a   getID (GroupChannel' a) = getID a   getID (GuildChannel' a) = getID a -instance FromJSON Channel where-  parseJSON = withObject "Channel" $ \v -> do-    type_ <- v .: "type"+instance Aeson.FromJSON Channel where+  parseJSON = Aeson.withObject "Channel" $ \v -> do+    type_ <- v Aeson..: "type"      case type_ of-      GuildTextType -> GuildChannel' <$> parseJSON (Object v)-      GuildVoiceType -> GuildChannel' <$> parseJSON (Object v)-      GuildCategoryType -> GuildChannel' <$> parseJSON (Object v)-      DMType -> DMChannel' <$> parseJSON (Object v)-      GroupDMType -> GroupChannel' <$> parseJSON (Object v)+      GuildTextType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v)+      GuildVoiceType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v)+      GuildCategoryType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v)+      DMType -> DMChannel' <$> Aeson.parseJSON (Aeson.Object v)+      GroupDMType -> GroupChannel' <$> Aeson.parseJSON (Aeson.Object v)+      GuildNewsType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v)+      GuildNewsThreadType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v)+      GuildPublicThreadType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v)+      GuildPrivateThreadType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v)+      GuildStageVoiceType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v)+      GuildDirectoryType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v)+      GuildForumType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v)  data instance Partial Channel = PartialChannel   { id :: Snowflake Channel   , name :: Text-  , type_ :: !ChannelType+  , type_ :: ChannelType   , permissions :: Maybe Permissions   , parentID :: Maybe (Snowflake Category)   }-  deriving (Show, Eq, Generic)-  deriving (TextShow) via TSG.FromGeneric (Partial Channel)-  deriving (ToJSON, FromJSON) via CalamityJSON (Partial Channel)+  deriving (Show, Eq)   deriving (HasID Channel) via HasIDField "id" (Partial Channel)+  deriving (Aeson.ToJSON) via CalamityToJSON (Partial Channel)++instance CalamityToJSON' (Partial Channel) where+  toPairs PartialChannel {..} =+    [ "id" .= id+    , "name" .= name+    , "type" .= type_+    , "permissions" .?= permissions+    , "parent_id" .?= parentID+    ]++instance Aeson.FromJSON (Partial Channel) where+  parseJSON = Aeson.withObject "Partial Channel" $ \v ->+    PartialChannel+      <$> v .: "id"+      <*> v .: "name"+      <*> v .: "type"+      <*> v .:? "permissions"+      <*> v .:? "parent_id"++$(deriveTextShow ''Channel)+$(deriveTextShow 'PartialChannel)+$(makeFieldLabelsNoPrefix ''Channel)+$(makeFieldLabelsNoPrefix 'PartialChannel)

@@ -1,15 +1,17 @@+{-# LANGUAGE TemplateHaskell #-}+ -- | Message attachments module Calamity.Types.Model.Channel.Attachment (   Attachment (..), ) where  import Calamity.Types.Snowflake-import Data.Aeson+import Data.Aeson ((.:), (.:?))+import qualified Data.Aeson as Aeson import Data.Text (Text) import Data.Word-import GHC.Generics-import TextShow-import qualified TextShow.Generic as TSG+import Optics.TH+import TextShow.TH  fuseTup2 :: Monad f => (f a, f b) -> f (a, b) fuseTup2 (a, b) = do@@ -19,36 +21,28 @@  data Attachment = Attachment   { id :: Snowflake Attachment-  , filename :: !Text+  , filename :: Text   , size :: Word64-  , url :: !Text-  , proxyUrl :: !Text-  , dimensions :: !(Maybe (Word64, Word64))+  , url :: Text+  , proxyUrl :: Text+  , dimensions :: Maybe (Word64, Word64)   }-  deriving (Eq, Show, Generic)-  deriving (TextShow) via TSG.FromGeneric Attachment+  deriving (Eq, Show)   deriving (HasID Attachment) via HasIDField "id" Attachment -instance ToJSON Attachment where-  toJSON Attachment {id, filename, size, url, proxyUrl, dimensions = Just (width, height)} =-    object-      [ "id" .= id-      , "filename" .= filename-      , "size" .= size-      , "url" .= url-      , "proxy_url" .= proxyUrl-      , "width" .= width-      , "height" .= height-      ]-  toJSON Attachment {id, filename, size, url, proxyUrl} =-    object ["id" .= id, "filename" .= filename, "size" .= size, "url" .= url, "proxy_url" .= proxyUrl]+$(deriveTextShow ''Attachment)+$(makeFieldLabelsNoPrefix ''Attachment) -instance FromJSON Attachment where-  parseJSON = withObject "Attachment" $ \v -> do+instance Aeson.FromJSON Attachment where+  parseJSON = Aeson.withObject "Attachment" $ \v -> do     width <- v .:? "width"     height <- v .:? "height" -    Attachment <$> v .: "id" <*> v .: "filename" <*> v .: "size" <*> v .: "url" <*> v .: "proxy_url"+    Attachment+      <$> v .: "id"+      <*> v .: "filename"+      <*> v .: "size"+      <*> v .: "url"+      <*> v .: "proxy_url"       <*> pure         (fuseTup2 (width, height))-

@@ -1,13 +1,12 @@+{-# LANGUAGE TemplateHaskell #-}+ -- | Types of channels module Calamity.Types.Model.Channel.ChannelType (ChannelType (..)) where -import Data.Aeson+import qualified Data.Aeson as Aeson import Data.Scientific--import GHC.Generics--import TextShow-import qualified TextShow.Generic as TSG+import Optics.TH+import TextShow.TH  -- Thanks sbrg (https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hsfield#L182) data ChannelType@@ -16,18 +15,36 @@   | GuildVoiceType   | GroupDMType   | GuildCategoryType-  deriving (Eq, Generic, Show, Enum)-  deriving (TextShow) via TSG.FromGeneric ChannelType+  | GuildNewsType+  | GuildNewsThreadType+  | GuildPublicThreadType+  | GuildPrivateThreadType+  | GuildStageVoiceType+  | GuildDirectoryType+  | GuildForumType+  deriving (Eq, Show, Enum) -instance ToJSON ChannelType where-  toJSON t = Number $ fromIntegral (fromEnum t)+$(deriveTextShow ''ChannelType)+$(makeFieldLabelsNoPrefix ''ChannelType) -instance FromJSON ChannelType where-  parseJSON = withScientific "ChannelType" $ \n -> case toBoundedInteger @Int n of+instance Aeson.ToJSON ChannelType where+  toJSON t = Aeson.toJSON (fromEnum t)+  toEncoding t = Aeson.toEncoding (fromEnum t)++instance Aeson.FromJSON ChannelType where+  parseJSON = Aeson.withScientific "ChannelType" $ \n -> case toBoundedInteger @Int n of     Just v -> case v of       0 -> pure GuildTextType       1 -> pure DMType       2 -> pure GuildVoiceType+      3 -> pure GroupDMType       4 -> pure GuildCategoryType+      5 -> pure GuildNewsType+      10 -> pure GuildNewsThreadType+      11 -> pure GuildPublicThreadType+      12 -> pure GuildPrivateThreadType+      13 -> pure GuildStageVoiceType+      14 -> pure GuildDirectoryType+      15 -> pure GuildForumType       _ -> fail $ "Invalid ChannelType: " <> show n     Nothing -> fail $ "Invalid ChannelType: " <> show n

@@ -1,3 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+ -- | Message components module Calamity.Types.Model.Channel.Component (   CustomID (..),@@ -20,77 +22,83 @@   componentType, ) where -import Calamity.Internal.AesonThings+import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=)) import Calamity.Types.Model.Guild.Emoji import Control.Monad (replicateM)-import Data.Aeson+import Data.Aeson ((.!=), (.:), (.:?))+import qualified Data.Aeson as Aeson import Data.Scientific (toBoundedInteger) import qualified Data.Text as T-import GHC.Generics+import Optics.TH import System.Random (Uniform) import System.Random.Stateful (Uniform (uniformM), UniformRange (uniformRM))-import TextShow-import qualified TextShow.Generic as TSG+import TextShow.TH+import Data.Maybe (catMaybes)  newtype CustomID = CustomID T.Text-  deriving stock (Eq, Ord, Show, Generic)-  deriving (TextShow) via TSG.FromGeneric CustomID-  deriving (ToJSON, FromJSON) via T.Text+  deriving stock (Eq, Ord, Show)+  deriving (Aeson.ToJSON, Aeson.FromJSON) via T.Text +$(deriveTextShow ''CustomID)+ instance Uniform CustomID where   uniformM = ((CustomID . T.pack) <$>) . replicateM 16 . uniformRM ('a', 'z') -data Button = Button-  { style :: ButtonStyle-  , label :: Maybe T.Text-  , emoji :: Maybe RawEmoji-  , disabled :: Bool-  , customID :: CustomID-  }-  deriving (Show, Generic)-  deriving (TextShow) via TSG.FromGeneric Button-  deriving (ToJSON) via CalamityJSONKeepNothing Button-  deriving-    (FromJSON)-    via WithSpecialCases-          '["disabled" `IfNoneThen` DefaultToFalse]-          Button+data ComponentType+  = ActionRowType+  | ButtonType+  | SelectType+  | TextInputType+  deriving (Eq, Show) -data LinkButton = LinkButton-  { stype :: ButtonStyle-  , label :: Maybe T.Text-  , emoji :: Maybe RawEmoji-  , url :: T.Text-  , disabled :: Bool-  }-  deriving (Show, Generic)-  deriving (TextShow) via TSG.FromGeneric LinkButton-  deriving (ToJSON) via CalamityJSONKeepNothing LinkButton-  deriving-    (FromJSON)-    via WithSpecialCases-          '["disabled" `IfNoneThen` DefaultToFalse]-          LinkButton+$(deriveTextShow ''ComponentType) +instance Aeson.ToJSON ComponentType where+  toJSON x = Aeson.toJSON @Int $ case x of+    ActionRowType -> 1+    ButtonType -> 2+    SelectType -> 3+    TextInputType -> 4+  toEncoding x = Aeson.toEncoding @Int $ case x of+    ActionRowType -> 1+    ButtonType -> 2+    SelectType -> 3+    TextInputType -> 4++instance Aeson.FromJSON ComponentType where+  parseJSON = Aeson.withScientific "Components.ComponentType" $ \n -> case toBoundedInteger @Int n of+    Just 1 -> pure ActionRowType+    Just 2 -> pure ButtonType+    Just 3 -> pure SelectType+    Just 4 -> pure TextInputType+    _ -> fail $ "Invalid ComponentType: " <> show n+ data ButtonStyle   = ButtonPrimary   | ButtonSecondary   | ButtonSuccess   | ButtonDanger   | ButtonLink-  deriving (Eq, Show, Generic)-  deriving (TextShow) via TSG.FromGeneric ButtonStyle+  deriving (Eq, Show) -instance ToJSON ButtonStyle where-  toJSON t = toJSON @Int $ case t of+$(deriveTextShow ''ButtonStyle)++instance Aeson.ToJSON ButtonStyle where+  toJSON t = Aeson.toJSON @Int $ case t of     ButtonPrimary -> 1     ButtonSecondary -> 2     ButtonSuccess -> 3     ButtonDanger -> 4     ButtonLink -> 5+  toEncoding t = Aeson.toEncoding @Int $ case t of+    ButtonPrimary -> 1+    ButtonSecondary -> 2+    ButtonSuccess -> 3+    ButtonDanger -> 4+    ButtonLink -> 5 -instance FromJSON ButtonStyle where-  parseJSON = withScientific "ButtonStyle" $ \n -> case toBoundedInteger @Int n of+instance Aeson.FromJSON ButtonStyle where+  parseJSON = Aeson.withScientific "Components.ButtonStyle" $ \n -> case toBoundedInteger @Int n of     Just v -> case v of       1 -> pure ButtonPrimary       2 -> pure ButtonSecondary@@ -100,6 +108,71 @@       _ -> fail $ "Invalid ButtonStyle: " <> show n     Nothing -> fail $ "Invalid ButtonStyle: " <> show n +data Button = Button+  { style :: ButtonStyle+  , label :: Maybe T.Text+  , emoji :: Maybe RawEmoji+  , disabled :: Bool+  , customID :: CustomID+  }+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON Button++instance CalamityToJSON' Button where+  toPairs Button {..} =+    [ "style" .= style+    , "label" .?= label+    , "emoji" .?= emoji+    , "disabled" .= disabled+    , "custom_id" .= customID+    , "type" .= ButtonType+    ]++$(deriveTextShow ''Button)+$(makeFieldLabelsNoPrefix ''Button)+++instance Aeson.FromJSON Button where+  parseJSON = Aeson.withObject "Components.Button" $ \v ->+    Button+      <$> v .: "style"+      <*> v .:? "label"+      <*> v .:? "emoji"+      <*> v .:? "disabled" .!= False+      <*> v .: "custom_id"++data LinkButton = LinkButton+  { style :: ButtonStyle+  , label :: Maybe T.Text+  , emoji :: Maybe RawEmoji+  , url :: T.Text+  , disabled :: Bool+  }+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON LinkButton++instance CalamityToJSON' LinkButton where+  toPairs LinkButton {..} =+      [ "style" .= style+      , "label" .?= label+      , "emoji" .?= emoji+      , "url" .= url+      , "disabled" .= disabled+      , "type" .= ButtonType+      ]++instance Aeson.FromJSON LinkButton where+  parseJSON = Aeson.withObject "Components.Linkbutton" $ \v ->+    LinkButton+      <$> v .: "style"+      <*> v .:? "label"+      <*> v .:? "emoji"+      <*> v .: "url"+      <*> v .:? "disabled" .!= False++$(deriveTextShow ''LinkButton)+$(makeFieldLabelsNoPrefix ''LinkButton)+ {- | Constuct a non-disabled 'Button' with the given 'ButtonStyle' and 'CustomID',  all other fields are set to 'Nothing' -}@@ -134,6 +207,37 @@   LinkButton lbutton' s lnk lbl = LinkButton s (Just lbl) Nothing lnk False +data SelectOption = SelectOption+  { label :: T.Text+  , value :: T.Text+  , description :: Maybe T.Text+  , emoji :: Maybe RawEmoji+  , default_ :: Bool+  }+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON SelectOption++instance CalamityToJSON' SelectOption where+  toPairs SelectOption {..} =+      [ "label" .= label+      , "value" .= value+      , "description" .?= description+      , "emoji" .?= emoji+      , "default" .= default_+      ]++instance Aeson.FromJSON SelectOption where+  parseJSON = Aeson.withObject "Components.SelectOption" $ \v ->+    SelectOption+      <$> v .: "label"+      <*> v .: "value"+      <*> v .:? "description"+      <*> v .:? "emoji"+      <*> v .:? "default" .!= False++$(deriveTextShow ''SelectOption)+$(makeFieldLabelsNoPrefix ''SelectOption)+ data Select = Select   { options :: [SelectOption]   , placeholder :: Maybe T.Text@@ -142,31 +246,33 @@   , disabled :: Bool   , customID :: CustomID   }-  deriving (Show, Generic)-  deriving (TextShow) via TSG.FromGeneric Select-  deriving (ToJSON) via CalamityJSONKeepNothing Select-  deriving-    (FromJSON)-    via WithSpecialCases-          '["disabled" `IfNoneThen` DefaultToFalse]-          Select+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON Select -data SelectOption = SelectOption-  { label :: T.Text-  , value :: T.Text-  , description :: Maybe T.Text-  , emoji :: Maybe RawEmoji-  , default_ :: Bool-  }-  deriving (Show, Generic)-  deriving (TextShow) via TSG.FromGeneric SelectOption-  deriving (ToJSON) via CalamityJSONKeepNothing SelectOption-  deriving-    (FromJSON)-    via WithSpecialCases-          '["default" `IfNoneThen` DefaultToFalse]-          SelectOption+instance CalamityToJSON' Select where+  toPairs Select {..} =+      [ "options" .= options+      , "placeholder" .?= placeholder+      , "min_values" .?= minValues+      , "max_values" .?= maxValues+      , "disabled" .= disabled+      , "custom_id" .= customID+      , "type" .= SelectType+      ] +instance Aeson.FromJSON Select where+  parseJSON = Aeson.withObject "Components.Select" $ \v ->+    Select+      <$> v .: "options"+      <*> v .:? "placeholder"+      <*> v .:? "min_values"+      <*> v .:? "max_values"+      <*> v .:? "disabled" .!= False+      <*> v .: "custom_id"++$(deriveTextShow ''Select)+$(makeFieldLabelsNoPrefix ''Select)+ select :: [SelectOption] -> CustomID -> Select select o = Select o Nothing Nothing Nothing False @@ -178,6 +284,29 @@   SelectOption sopt l v = SelectOption l v Nothing Nothing False +data TextInputStyle+  = TextInputShort+  | TextInputParagraph+  deriving (Show)++$(deriveTextShow ''TextInputStyle)++instance Aeson.ToJSON TextInputStyle where+  toJSON t = Aeson.toJSON @Int $ case t of+    TextInputShort -> 1+    TextInputParagraph -> 2+  toEncoding t = Aeson.toEncoding @Int $ case t of+    TextInputShort -> 1+    TextInputParagraph -> 2++instance Aeson.FromJSON TextInputStyle where+  parseJSON = Aeson.withScientific "Components.TextInputStyle" $ \n -> case toBoundedInteger @Int n of+    Just v -> case v of+      1 -> pure TextInputShort+      2 -> pure TextInputParagraph+      _ -> fail $ "Invalid TextInputStyle: " <> show n+    Nothing -> fail $ "Invalid TextInputStyle: " <> show n+ data TextInput = TextInput   { style :: TextInputStyle   , label :: T.Text@@ -188,33 +317,36 @@   , placeholder :: Maybe T.Text   , customID :: CustomID   }-  deriving (Show, Generic)-  deriving (TextShow) via TSG.FromGeneric TextInput-  deriving (ToJSON) via CalamityJSONKeepNothing TextInput-  deriving-    (FromJSON)-    via WithSpecialCases-          '["required" `IfNoneThen` DefaultToFalse]-          TextInput+  deriving (Show)+  deriving (Aeson.ToJSON) via CalamityToJSON TextInput -data TextInputStyle-  = TextInputShort-  | TextInputParagraph-  deriving (Show, Generic)-  deriving (TextShow) via TSG.FromGeneric TextInputStyle+instance CalamityToJSON' TextInput where+  toPairs TextInput {..} =+      [ "style" .= style+      , "label" .= label+      , "min_length" .= minLength+      , "max_length" .= maxLength+      , "required" .= required+      , "value" .= value+      , "placeholder" .= placeholder+      , "custom_id" .= customID+      , "type" .= TextInputType+      ] -instance ToJSON TextInputStyle where-  toJSON t = toJSON @Int $ case t of-    TextInputShort -> 1-    TextInputParagraph -> 2+instance Aeson.FromJSON TextInput where+  parseJSON = Aeson.withObject "Components.TextInput" $ \v ->+    TextInput+      <$> v .: "style"+      <*> v .: "label"+      <*> v .:? "min_length"+      <*> v .:? "max_length"+      <*> v .:? "required" .!= False+      <*> v .:? "value"+      <*> v .:? "placeholder"+      <*> v .: "custom_id" -instance FromJSON TextInputStyle where-  parseJSON = withScientific "TextInputStyle" $ \n -> case toBoundedInteger @Int n of-    Just v -> case v of-      1 -> pure TextInputShort-      2 -> pure TextInputParagraph-      _ -> fail $ "Invalid TextInputStyle: " <> show n-    Nothing -> fail $ "Invalid TextInputStyle: " <> show n+$(deriveTextShow ''TextInput)+$(makeFieldLabelsNoPrefix ''TextInput)  textInput ::   TextInputStyle ->@@ -230,35 +362,42 @@   | LinkButton' LinkButton   | Select' Select   | TextInput' TextInput-  deriving (Show, Generic)-  deriving (TextShow) via TSG.FromGeneric Component+  deriving (Show) -instance ToJSON Component where+$(deriveTextShow ''Component)++instance Aeson.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)-          LinkButton' lb -> (toJSON lb, 2 :: Int)-          Select' s -> (toJSON s, 3 :: Int)-          TextInput' ti -> (toJSON ti, 4 :: Int)-     in Object (inner <> ("type" .= type_))+    case t of+      ActionRow' xs -> Aeson.object . catMaybes $ ["components" .= xs, "type" .= ActionRowType]+      Button' b -> Aeson.toJSON b+      LinkButton' lb -> Aeson.toJSON lb+      Select' s -> Aeson.toJSON s+      TextInput' ti -> Aeson.toJSON ti -instance FromJSON Component where-  parseJSON = withObject "Component" $ \v -> do-    type_ :: Int <- v .: "type"+  toEncoding t =+    case t of+      ActionRow' xs -> Aeson.pairs . mconcat . catMaybes $ ["components" .= xs, "type" .= ActionRowType]+      Button' b -> Aeson.toEncoding b+      LinkButton' lb -> Aeson.toEncoding lb+      Select' s -> Aeson.toEncoding s+      TextInput' ti -> Aeson.toEncoding ti +instance Aeson.FromJSON Component where+  parseJSON = Aeson.withObject "Component" $ \v -> do+    type_ :: ComponentType <- v .: "type"+     case type_ of-      1 -> ActionRow' <$> v .: "components"-      2 -> do+      ActionRowType -> ActionRow' <$> v .: "components"+      ButtonType -> do         cid :: Maybe CustomID <- v .:? "custom_id"         url :: Maybe T.Text <- v .:? "url"         case (cid, url) of-          (Just _, _) -> Button' <$> parseJSON (Object v)-          (_, Just _) -> LinkButton' <$> parseJSON (Object v)+          (Just _, _) -> Button' <$> Aeson.parseJSON (Aeson.Object v)+          (_, Just _) -> LinkButton' <$> Aeson.parseJSON (Aeson.Object v)           _ -> fail $ "Impossible button: " <> show v-      3 -> Select' <$> parseJSON (Object v)-      4 -> TextInput' <$> parseJSON (Object v)-      _ -> fail $ "Invalid ComponentType: " <> show type_+      SelectType -> Select' <$> Aeson.parseJSON (Aeson.Object v)+      TextInputType -> TextInput' <$> Aeson.parseJSON (Aeson.Object v)  componentType :: Component -> ComponentType componentType (ActionRow' _) = ActionRowType@@ -266,26 +405,3 @@ componentType (LinkButton' _) = ButtonType componentType (Select' _) = SelectType componentType (TextInput' _) = TextInputType--data ComponentType-  = ActionRowType-  | ButtonType-  | SelectType-  | TextInputType-  deriving (Eq, Show, Generic)-  deriving (TextShow) via TSG.FromGeneric ComponentType--instance ToJSON ComponentType where-  toJSON x = toJSON @Int $ case x of-    ActionRowType -> 1-    ButtonType -> 2-    SelectType -> 3-    TextInputType -> 4--instance FromJSON ComponentType where-  parseJSON = withScientific "ComponentType" $ \n -> case toBoundedInteger @Int n of-    Just 1 -> pure ActionRowType-    Just 2 -> pure ButtonType-    Just 3 -> pure SelectType-    Just 4 -> pure TextInputType-    _ -> fail $ "Invalid ComponentType: " <> show n

@@ -1,42 +1,35 @@+{-# LANGUAGE TemplateHaskell #-}+ -- | A DM channel with a single person module Calamity.Types.Model.Channel.DM (DMChannel (..)) where -import Calamity.Internal.AesonThings-import Calamity.Internal.OverriddenVia-import Calamity.Internal.Utils import {-# SOURCE #-} Calamity.Types.Model.Channel import {-# SOURCE #-} Calamity.Types.Model.Channel.Message import Calamity.Types.Model.User import Calamity.Types.Snowflake-import Control.DeepSeq (NFData)-import Data.Aeson+import Data.Aeson ((.:), (.:?))+import qualified Data.Aeson as Aeson import Data.Time-import Data.Vector.Unboxing (Vector)-import GHC.Generics-import TextShow-import qualified TextShow.Generic as TSG--data DMChannel' = DMChannel'-  { id :: Snowflake DMChannel-  , lastMessageID :: Maybe (Snowflake Message)-  , lastPinTimestamp :: Maybe (CalamityFromStringShow UTCTime)-  , recipients :: AesonVector (Snowflake User)-  }-  deriving (Generic)-  deriving (TextShow) via TSG.FromGeneric DMChannel'-  deriving-    (FromJSON)-    via WithSpecialCases-          '["recipients" `ExtractArrayField` "id"]-          DMChannel'+import Optics.TH+import qualified TextShow  data DMChannel = DMChannel   { id :: Snowflake DMChannel   , lastMessageID :: Maybe (Snowflake Message)   , lastPinTimestamp :: Maybe UTCTime-  , recipients :: Vector (Snowflake User)+  , recipients :: [User]   }-  deriving (Show, Eq, Generic, NFData)-  deriving (TextShow, FromJSON) via OverriddenVia DMChannel DMChannel'+  deriving (Show, Eq)+  deriving (TextShow.TextShow) via TextShow.FromStringShow DMChannel   deriving (HasID DMChannel) via HasIDField "id" DMChannel   deriving (HasID Channel) via HasIDFieldCoerce' "id" DMChannel++instance Aeson.FromJSON DMChannel where+  parseJSON = Aeson.withObject "DMChannel" $ \v ->+    DMChannel+      <$> v .: "id"+      <*> v .:? "last_pin_timestamp"+      <*> v .:? "last_message_id"+      <*> v .: "recipients"++$(makeFieldLabelsNoPrefix ''DMChannel)

@@ -1,105 +1,130 @@+{-# LANGUAGE TemplateHaskell #-}+ -- | Message embeds module Calamity.Types.Model.Channel.Embed (-    Embed (..),-    embedFooter,-    embedImage,-    embedThumbnail,-    embedAuthor,-    embedAuthor',-    embedField,-    EmbedFooter (..),-    EmbedImage (..),-    EmbedThumbnail (..),-    EmbedVideo (..),-    EmbedProvider (..),-    EmbedAuthor (..),-    EmbedField (..),+  Embed (..),+  embedFooter,+  embedImage,+  embedThumbnail,+  embedAuthor,+  embedAuthor',+  embedField,+  EmbedFooter (..),+  EmbedImage (..),+  EmbedThumbnail (..),+  EmbedVideo (..),+  EmbedProvider (..),+  EmbedAuthor (..),+  EmbedField (..), ) where -import Calamity.Internal.AesonThings-import Calamity.Internal.IntColour-import Calamity.Internal.OverriddenVia-import Calamity.Internal.Utils-import Control.Lens-import Data.Aeson+import Calamity.Internal.IntColour (IntColour (..))+import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=))+import Data.Aeson ((.!=), (.:), (.:?))+import qualified Data.Aeson as Aeson import Data.Colour (Colour) import Data.Default.Class-import Data.Generics.Labels () import Data.Semigroup import Data.Text (Text) import Data.Time import Data.Word-import GHC.Generics-import TextShow-import qualified TextShow.Generic as TSG--data Embed' = Embed'-    { title :: Maybe Text-    , type_ :: Maybe Text-    , description :: Maybe Text-    , url :: Maybe Text-    , timestamp :: Maybe (CalamityFromStringShow UTCTime)-    , color :: Maybe IntColour-    , footer :: Maybe EmbedFooter-    , image :: Maybe EmbedImage-    , thumbnail :: Maybe EmbedThumbnail-    , video :: Maybe EmbedVideo-    , provider :: Maybe EmbedProvider-    , author :: Maybe EmbedAuthor-    , fields :: [EmbedField]-    }-    deriving (Generic)-    deriving (FromJSON) via WithSpecialCases '[IfNoneThen "fields" DefaultToEmptyArray] Embed'-    deriving (ToJSON) via CalamityJSON Embed'-    deriving (TextShow) via TSG.FromGeneric Embed'+import Optics ((%~), (&), (^.))+import Optics.TH+import qualified TextShow+import TextShow.TH  data Embed = Embed-    { title :: Maybe Text-    , type_ :: Maybe Text-    , description :: Maybe Text-    , url :: Maybe Text-    , timestamp :: Maybe UTCTime-    , color :: Maybe (Colour Double)-    , footer :: Maybe EmbedFooter-    , image :: Maybe EmbedImage-    , thumbnail :: Maybe EmbedThumbnail-    , video :: Maybe EmbedVideo-    , provider :: Maybe EmbedProvider-    , author :: Maybe EmbedAuthor-    , fields :: [EmbedField]-    }-    deriving (Eq, Show, Generic, Default)-    deriving (TextShow, FromJSON, ToJSON) via OverriddenVia Embed Embed'+  { title :: Maybe Text+  , type_ :: Maybe Text+  , description :: Maybe Text+  , url :: Maybe Text+  , timestamp :: Maybe UTCTime+  , color :: Maybe (Colour Double)+  , footer :: Maybe EmbedFooter+  , image :: Maybe EmbedImage+  , thumbnail :: Maybe EmbedThumbnail+  , video :: Maybe EmbedVideo+  , provider :: Maybe EmbedProvider+  , author :: Maybe EmbedAuthor+  , fields :: [EmbedField]+  }+  deriving (Eq, Show)+  deriving (TextShow.TextShow) via TextShow.FromStringShow Embed+  deriving (Aeson.ToJSON) via CalamityToJSON Embed -instance Semigroup Embed where-    l <> r =-        l-            & #title %~ (<> (r ^. #title))-            & #type_ %~ getLast . (<> Last (r ^. #type_)) . Last-            & #description %~ (<> (r ^. #description))-            & #url %~ getLast . (<> Last (r ^. #url)) . Last-            & #timestamp %~ getLast . (<> Last (r ^. #timestamp)) . Last-            & #color %~ getLast . (<> Last (r ^. #color)) . Last-            & #footer %~ (<> (r ^. #footer))-            & #image %~ getLast . (<> Last (r ^. #image)) . Last-            & #thumbnail %~ getLast . (<> Last (r ^. #thumbnail)) . Last-            & #video %~ getLast . (<> Last (r ^. #video)) . Last-            & #provider %~ getLast . (<> Last (r ^. #provider)) . Last-            & #author %~ getLast . (<> Last (r ^. #author)) . Last-            & #fields %~ (<> (r ^. #fields))+instance Default Embed where+  def =+    Embed+      Nothing+      Nothing+      Nothing+      Nothing+      Nothing+      Nothing+      Nothing+      Nothing+      Nothing+      Nothing+      Nothing+      Nothing+      [] -instance Monoid Embed where-    mempty = def+instance CalamityToJSON' Embed where+  toPairs Embed {..} =+    [ "title" .?= title+    , "type" .?= type_+    , "description" .?= description+    , "url" .?= url+    , "timestamp" .?= timestamp+    , "color" .?= (IntColour <$> color)+    , "footer" .?= footer+    , "image" .?= image+    , "thumbnail" .?= thumbnail+    , "video" .?= video+    , "provider" .?= provider+    , "author" .?= author+    , "fields" .= fields+    ] +instance Aeson.FromJSON Embed where+  parseJSON = Aeson.withObject "Embed" $ \v ->+    Embed+      <$> v .:? "title"+      <*> v .:? "type"+      <*> v .:? "description"+      <*> v .:? "url"+      <*> v .:? "timestamp"+      <*> (fmap fromIntColour <$> v .:? "color")+      <*> v .:? "footer"+      <*> v .:? "image"+      <*> v .:? "thumbnail"+      <*> v .:? "video"+      <*> v .:? "provider"+      <*> v .:? "author"+      <*> v .:? "fields" .!= []+ data EmbedFooter = EmbedFooter-    { text :: Text-    , iconUrl :: Maybe Text-    , proxyIconUrl :: Maybe Text-    }-    deriving (Eq, Show, Generic)-    deriving (TextShow) via TSG.FromGeneric EmbedFooter-    deriving (ToJSON, FromJSON) via CalamityJSON EmbedFooter+  { text :: Text+  , iconUrl :: Maybe Text+  , proxyIconUrl :: Maybe Text+  }+  deriving (Eq, Show)+  deriving (Aeson.ToJSON) via CalamityToJSON EmbedFooter +instance CalamityToJSON' EmbedFooter where+  toPairs EmbedFooter {..} =+    [ "text" .= text+    , "icon_url" .?= iconUrl+    , "proxy_icon_url" .?= proxyIconUrl+    ]++instance Aeson.FromJSON EmbedFooter where+  parseJSON = Aeson.withObject "EmbedFooter" $ \v ->+    EmbedFooter+      <$> v .: "text"+      <*> v .:? "icon_url"+      <*> v .:? "proxy_icon_url"+ {- | Create an embed footer with a provided content   The remaining fields are set to Nothing@@ -107,23 +132,31 @@ embedFooter :: Text -> EmbedFooter embedFooter text = EmbedFooter text Nothing Nothing -instance Semigroup EmbedFooter where-    l <> r =-        l-            & #text %~ (<> (r ^. #text))-            & #iconUrl %~ getLast . (<> Last (r ^. #iconUrl)) . Last-            & #proxyIconUrl %~ getLast . (<> Last (r ^. #proxyIconUrl)) . Last- data EmbedImage = EmbedImage-    { url :: Text-    , proxyUrl :: Maybe Text-    , width :: Maybe Word64-    , height :: Maybe Word64-    }-    deriving (Eq, Show, Generic)-    deriving (TextShow) via TSG.FromGeneric EmbedImage-    deriving (FromJSON, ToJSON) via CalamityJSON EmbedImage+  { url :: Text+  , proxyUrl :: Maybe Text+  , width :: Maybe Word64+  , height :: Maybe Word64+  }+  deriving (Eq, Show)+  deriving (Aeson.ToJSON) via CalamityToJSON EmbedImage +instance CalamityToJSON' EmbedImage where+  toPairs EmbedImage {..} =+    [ "url" .= url+    , "proxy_url" .= proxyUrl+    , "width" .= width+    , "height" .= height+    ]++instance Aeson.FromJSON EmbedImage where+  parseJSON = Aeson.withObject "EmbedImage" $ \v ->+    EmbedImage+      <$> v .: "url"+      <*> v .:? "proxy_url"+      <*> v .:? "width"+      <*> v .:? "height"+ {- | Create an embed image with a provided url   The remaining fields are set to Nothing@@ -132,15 +165,30 @@ embedImage url = EmbedImage url Nothing Nothing Nothing  data EmbedThumbnail = EmbedThumbnail-    { url :: Text-    , proxyUrl :: Maybe Text-    , width :: Maybe Word64-    , height :: Maybe Word64-    }-    deriving (Eq, Show, Generic)-    deriving (TextShow) via TSG.FromGeneric EmbedThumbnail-    deriving (FromJSON, ToJSON) via CalamityJSON EmbedThumbnail+  { url :: Text+  , proxyUrl :: Maybe Text+  , width :: Maybe Word64+  , height :: Maybe Word64+  }+  deriving (Eq, Show)+  deriving (Aeson.ToJSON) via CalamityToJSON EmbedThumbnail +instance CalamityToJSON' EmbedThumbnail where+  toPairs EmbedThumbnail {..} =+    [ "url" .= url+    , "proxy_url" .?= proxyUrl+    , "width" .?= width+    , "height" .?= height+    ]++instance Aeson.FromJSON EmbedThumbnail where+  parseJSON = Aeson.withObject "EmbedThumbnail" $ \v ->+    EmbedThumbnail+      <$> v .: "url"+      <*> v .:? "proxy_url"+      <*> v .:? "width"+      <*> v .:? "height"+ {- | Create an embed thumbnail with a provided url   The remaining fields are set to Nothing@@ -149,33 +197,77 @@ embedThumbnail url = EmbedThumbnail url Nothing Nothing Nothing  data EmbedVideo = EmbedVideo-    { url :: Maybe Text-    , proxyUrl :: Maybe Text-    , width :: Maybe Word64-    , height :: Maybe Word64-    }-    deriving (Eq, Show, Generic)-    deriving (TextShow) via TSG.FromGeneric EmbedVideo-    deriving (FromJSON, ToJSON) via CalamityJSON EmbedVideo+  { url :: Maybe Text+  , proxyUrl :: Maybe Text+  , width :: Maybe Word64+  , height :: Maybe Word64+  }+  deriving (Eq, Show)+  deriving (Aeson.ToJSON) via CalamityToJSON EmbedVideo +instance CalamityToJSON' EmbedVideo where+  toPairs EmbedVideo {..} =+    [ "url" .= url+    , "proxy_url" .= proxyUrl+    , "width" .= width+    , "height" .= height+    ]++instance Aeson.FromJSON EmbedVideo where+  parseJSON = Aeson.withObject "EmbedVideo" $ \v ->+    EmbedVideo+      <$> v .: "url"+      <*> v .:? "proxy_url"+      <*> v .:? "width"+      <*> v .:? "height"+ data EmbedProvider = EmbedProvider-    { name :: Maybe Text-    , url :: Maybe Text-    }-    deriving (Eq, Show, Generic)-    deriving (TextShow) via TSG.FromGeneric EmbedProvider-    deriving (ToJSON, FromJSON) via CalamityJSON EmbedProvider+  { name :: Maybe Text+  , url :: Maybe Text+  }+  deriving (Eq, Show)+  deriving (Aeson.ToJSON) via CalamityToJSON EmbedProvider +instance CalamityToJSON' EmbedProvider where+  toPairs EmbedProvider {..} =+    [ "name" .= name+    , "url" .= url+    ]++instance Aeson.FromJSON EmbedProvider where+  parseJSON = Aeson.withObject "EmbedProvider" $ \v ->+    EmbedProvider+      <$> v .:? "name"+      <*> v .:? "url"+ data EmbedAuthor = EmbedAuthor-    { name :: Maybe Text-    , url :: Maybe Text-    , iconUrl :: Maybe Text-    , proxyIconURL :: Maybe Text-    }-    deriving (Eq, Show, Generic, Default)-    deriving (TextShow) via TSG.FromGeneric EmbedAuthor-    deriving (ToJSON, FromJSON) via CalamityJSON EmbedAuthor+  { name :: Maybe Text+  , url :: Maybe Text+  , iconUrl :: Maybe Text+  , proxyIconUrl :: Maybe Text+  }+  deriving (Eq, Show)+  deriving (Aeson.ToJSON) via CalamityToJSON EmbedAuthor +instance Default EmbedAuthor where+  def = EmbedAuthor Nothing Nothing Nothing Nothing++instance CalamityToJSON' EmbedAuthor where+  toPairs EmbedAuthor {..} =+    [ "name" .?= name+    , "url" .?= url+    , "icon_url" .?= iconUrl+    , "proxy_icon_url" .?= proxyIconUrl+    ]++instance Aeson.FromJSON EmbedAuthor where+  parseJSON = Aeson.withObject "EmbedAuthor" $ \v ->+    EmbedAuthor+      <$> v .:? "name"+      <*> v .:? "url"+      <*> v .:? "icon_url"+      <*> v .:? "proxy_icon_url"+ {- | Create an embed author with the given name   The remaining fields are set to Nothing@@ -188,34 +280,92 @@  The remaining fields are set to Nothing -} embedAuthor' ::-    -- | Name-    Text ->-    -- | Url-    Text ->-    -- | Icon url-    Text ->-    EmbedAuthor+  -- | Name+  Text ->+  -- | Url+  Text ->+  -- | Icon url+  Text ->+  EmbedAuthor embedAuthor' name url iconUrl = EmbedAuthor (Just name) (Just url) (Just iconUrl) Nothing  data EmbedField = EmbedField-    { name :: Text-    , value :: Text-    , inline :: Bool-    }-    deriving (Eq, Show, Generic)-    deriving (TextShow) via TSG.FromGeneric EmbedField-    deriving-        (FromJSON)-        via WithSpecialCases-                '[IfNoneThen "inline" DefaultToFalse]-                EmbedField-    deriving (ToJSON) via CalamityJSON EmbedField+  { name :: Text+  , value :: Text+  , inline :: Bool+  }+  deriving (Eq, Show)+  deriving (Aeson.ToJSON) via CalamityToJSON EmbedField +instance CalamityToJSON' EmbedField where+  toPairs EmbedField {..} =+    [ "name" .= name+    , "value" .= value+    , "inline" .= inline+    ]++instance Aeson.FromJSON EmbedField where+  parseJSON = Aeson.withObject "EmbedField" $ \v ->+    EmbedField+      <$> v .: "name"+      <*> v .: "value"+      <*> v .:? "inline" .!= False+ -- | Create a non-inline embed field embedField ::-    -- | Name-    Text ->-    -- | Value-    Text ->-    EmbedField+  -- | Name+  Text ->+  -- | Value+  Text ->+  EmbedField embedField name value = EmbedField name value False++$(makeFieldLabelsNoPrefix ''Embed)++$(deriveTextShow ''EmbedFooter)+$(makeFieldLabelsNoPrefix ''EmbedFooter)++$(deriveTextShow ''EmbedImage)+$(makeFieldLabelsNoPrefix ''EmbedImage)++$(deriveTextShow ''EmbedThumbnail)+$(makeFieldLabelsNoPrefix ''EmbedThumbnail)++$(deriveTextShow ''EmbedVideo)+$(makeFieldLabelsNoPrefix ''EmbedVideo)++$(deriveTextShow ''EmbedProvider)+$(makeFieldLabelsNoPrefix ''EmbedProvider)++$(deriveTextShow ''EmbedAuthor)+$(makeFieldLabelsNoPrefix ''EmbedAuthor)++$(deriveTextShow ''EmbedField)+$(makeFieldLabelsNoPrefix ''EmbedField)++instance Semigroup EmbedFooter where+  l <> r =+    l+      & #text %~ (<> (r ^. #text))+      & #iconUrl %~ getLast . (<> Last (r ^. #iconUrl)) . Last+      & #proxyIconUrl %~ getLast . (<> Last (r ^. #proxyIconUrl)) . Last++instance Semigroup Embed where+  l <> r =+    l+      & #title %~ (<> (r ^. #title))+      & #type_ %~ getLast . (<> Last (r ^. #type_)) . Last+      & #description %~ (<> (r ^. #description))+      & #url %~ getLast . (<> Last (r ^. #url)) . Last+      & #timestamp %~ getLast . (<> Last (r ^. #timestamp)) . Last+      & #color %~ getLast . (<> Last (r ^. #color)) . Last+      & #footer %~ (<> (r ^. #footer))+      & #image %~ getLast . (<> Last (r ^. #image)) . Last+      & #thumbnail %~ getLast . (<> Last (r ^. #thumbnail)) . Last+      & #video %~ getLast . (<> Last (r ^. #video)) . Last+      & #provider %~ getLast . (<> Last (r ^. #provider)) . Last+      & #author %~ getLast . (<> Last (r ^. #author)) . Last+      & #fields %~ (<> (r ^. #fields))++instance Monoid Embed where+  mempty = def

@@ -1,33 +1,18 @@+{-# LANGUAGE TemplateHaskell #-}+ -- | A Group Group channel module Calamity.Types.Model.Channel.Group (GroupChannel (..)) where -import Calamity.Internal.AesonThings-import Calamity.Internal.OverriddenVia-import Calamity.Internal.Utils import {-# SOURCE #-} Calamity.Types.Model.Channel import {-# SOURCE #-} Calamity.Types.Model.Channel.Message import Calamity.Types.Model.User import Calamity.Types.Snowflake-import Data.Aeson+import Data.Aeson ((.:), (.:?))+import qualified Data.Aeson as Aeson import Data.Text (Text) import Data.Time-import Data.Vector.Unboxing (Vector)-import GHC.Generics-import TextShow-import qualified TextShow.Generic as TSG--data GroupChannel' = GroupChannel'-  { id :: Snowflake GroupChannel-  , ownerID :: Snowflake User-  , lastMessageID :: Maybe (Snowflake Message)-  , lastPinTimestamp :: Maybe (CalamityFromStringShow UTCTime)-  , icon :: Maybe Text-  , recipients :: AesonVector (Snowflake User)-  , name :: Text-  }-  deriving (Generic)-  deriving (TextShow) via TSG.FromGeneric GroupChannel'-  deriving (ToJSON, FromJSON) via CalamityJSON GroupChannel'+import Optics.TH+import qualified TextShow  data GroupChannel = GroupChannel   { id :: Snowflake GroupChannel@@ -35,11 +20,24 @@   , lastMessageID :: Maybe (Snowflake Message)   , lastPinTimestamp :: Maybe UTCTime   , icon :: Maybe Text-  , recipients :: Vector (Snowflake User)+  , recipients :: [User]   , name :: Text   }-  deriving (Show, Eq, Generic)-  deriving (TextShow, ToJSON, FromJSON) via OverriddenVia GroupChannel GroupChannel'+  deriving (Show, Eq)+  deriving (TextShow.TextShow) via TextShow.FromStringShow GroupChannel   deriving (HasID GroupChannel) via HasIDField "id" GroupChannel   deriving (HasID Channel) via HasIDFieldCoerce' "id" GroupChannel   deriving (HasID User) via HasIDField "ownerID" GroupChannel++$(makeFieldLabelsNoPrefix ''GroupChannel)++instance Aeson.FromJSON GroupChannel where+  parseJSON = Aeson.withObject "GroupChannel" $ \v ->+    GroupChannel+      <$> v .: "id"+      <*> v .: "owner_id"+      <*> v .:? "last_message_id"+      <*> v .:? "last_pin_timestamp"+      <*> v .:? "icon"+      <*> v .: "recipients"+      <*> v .: "name"