diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,27 @@ # Changelog for Calamity +## 0.1.18.0 + +* Add raw message events: `RawMessageUpdateEvt`, `RawMessageDeleteEvt`, + `RawMessageDeleteBulkEvt`, `RawMessageReactionAddEvt`, + `RawMessageReactionRemoveEvt`, `RawMessageReactionRemoveAllEvt`. + +* Fixed bulk message deletes firing a message delete per deleted message, + instead of a bulk message delete event (I'm not sure how I did that). + +* Add `animated` field to `Partial Emoji`s. + +* Make show instances for `Partial Emoji` and `RawEmoji` show to their discord + representation. + +## 0.1.17.2 + +*2020-07-04* + +* Drop GHC-8.6.5, it doesn't like strictdata + +* Use unboxing-vector instead of doing stuff ourselves + ## 0.1.17.1 *2020-06-29* @@ -22,7 +44,7 @@ * Change how commands should be manually invoked from code, instead of firing a `"invoke-command"` custom event, now the `handleCommands` function should be used, which returns information about if the command succeeded. - + * Added `fetchHandler` for retrieving the command handler inside a command DSL. ## 0.1.15.0 @@ -62,7 +84,7 @@ * The `DecodeError` variant of the `RestError` type has been renamed to `InternalClientError` as all issues in the rest client now end up here. - + * We're now using `discord.com` instead of `discordapp.com` ## 0.1.14.4 @@ -152,7 +174,7 @@ * Renamed `Calamity.Commands.Parser.KleeneConcat` to `Calamity.Commands.Parser.KleeneStarConcat` and added `Calamity.Commands.Parser.KleenePlusConcat` - + * Added `Calamity.Types.Upgradeable` ## 0.1.9.2 @@ -177,7 +199,7 @@ * Added commands, located in `Calamity.Commands`, along with a DSL for declaring commands nicely. - + * Renamed `waitUntil` to `waitUntilM`, and introduced a variant with a pure check function that takes the original name of `waitUntil`. diff --git a/cabal.project b/cabal.project --- a/cabal.project +++ b/cabal.project @@ -1,6 +1,6 @@ -- Generated by stackage-to-hackage -with-compiler: ghc-8.8.3 +with-compiler: ghc packages: ./ diff --git a/calamity.cabal b/calamity.cabal --- a/calamity.cabal +++ b/calamity.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 4cd6c5a80a55753413c0b839551d9d76dac6c32465e782b04be30aa1a16abf24 +-- hash: eb69f9ccf663e6f7de402507416d61ec69ba3c89e2706f2a6db544aa7056696e name: calamity -version: 0.1.17.1 +version: 0.1.18.0 synopsis: A library for writing discord bots in haskell description: Please see the README on GitHub at category: Network, Web @@ -18,7 +18,7 @@ copyright: 2020 Ben Simms license: MIT license-file: LICENSE -tested-with: GHC == 8.6.5, GHC == 8.8.3 +tested-with: GHC == 8.8.3 build-type: Simple extra-source-files: README.md @@ -135,7 +135,7 @@ hs-source-dirs: src default-extensions: StrictData AllowAmbiguousTypes BlockArguments NoMonomorphismRestriction BangPatterns BinaryLiterals UndecidableInstances ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs DerivingVia DerivingStrategies GeneralizedNewtypeDeriving StandaloneDeriving DeriveAnyClass InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings OverloadedLabels PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables TupleSections TypeFamilies TypeSynonymInstances ViewPatterns DuplicateRecordFields TypeOperators TypeApplications RoleAnnotations - ghc-options: -fwrite-ide-info -hiedir=.hie -fplugin=Polysemy.Plugin -funbox-strict-fields -Wall -fno-warn-name-shadowing + ghc-options: -fplugin=Polysemy.Plugin -funbox-strict-fields -Wall -fno-warn-name-shadowing build-depends: aeson >=1.4 && <2 , async >=2.2 && <3 @@ -177,6 +177,7 @@ , time >=1.8 && <1.11 , typerep-map >=0.3 && <0.4 , unagi-chan >=0.4 && <0.5 + , unboxing-vector >=0.1 && <0.2 , unordered-containers >=0.2 && <0.3 , vector >=0.12 && <0.13 , websockets >=0.12 && <0.13 diff --git a/src/Calamity/Client/Client.hs b/src/Calamity/Client/Client.hs --- a/src/Calamity/Client/Client.hs +++ b/src/Calamity/Client/Client.hs @@ -50,7 +50,6 @@ import Data.Proxy import qualified Data.Text as S import Data.Time.Clock.POSIX -import Data.Traversable import Data.Typeable import qualified DiPolysemy as Di @@ -147,7 +146,7 @@ -- Reacting to a custom event: -- -- @ --- 'react' @(\''CustomEvt' "my-event" ('Data.Text.Text', 'Message')) $ \(s, m) -> +-- 'react' @(\''CustomEvt' "my-event" ('Data.Text.Text', 'Message')) $ \\(s, m) -> -- 'void' $ 'Calamity.Types.Tellable.tell' @'Data.Text.Text' m ("Somebody told me to tell you about: " '<>' s) -- @ -- @@ -230,7 +229,7 @@ -- Waiting for a message containing the text \"hi\": -- -- @ --- f = do msg \<\- 'waitUntil' @\''MessageCreateEvt' (\m -> 'Data.Text.Lazy.isInfixOf' "hi" $ m ^. #content) +-- f = do msg \<\- 'waitUntil' @\''MessageCreateEvt' (\\m -> 'Data.Text.Lazy.isInfixOf' "hi" $ m ^. #content) -- print $ msg ^. #content -- @ waitUntil @@ -269,7 +268,7 @@ -- Waiting for a message containing the text \"hi\": -- -- @ --- f = do msg \<\- 'waitUntilM' @\''MessageCreateEvt' (\m -> ('debug' $ "got message: " <> 'showt' msg) >> ('pure' $ 'Data.Text.Lazy.isInfixOf' "hi" $ m ^. #content)) +-- f = do msg \<\- 'waitUntilM' @\''MessageCreateEvt' (\\m -> ('debug' $ "got message: " <> 'showt' msg) >> ('pure' $ 'Data.Text.Lazy.isInfixOf' "hi" $ m ^. #content)) -- print $ msg ^. #content -- @ waitUntilM @@ -511,35 +510,62 @@ pure $ map ($ msg) (getEventHandlers @'MessageCreateEvt eh) handleEvent' eh evt@(MessageUpdate msg) = do - Just oldMsg <- getMessage (getID msg) + oldMsg <- getMessage (getID msg) updateCache evt - Just newMsg <- getMessage (getID msg) - pure $ map ($ (oldMsg, newMsg)) (getEventHandlers @'MessageUpdateEvt eh) + newMsg <- getMessage (getID msg) + let rawActions = map ($ msg) (getEventHandlers @'RawMessageUpdateEvt eh) + let actions = case (oldMsg, newMsg) of + (Just oldMsg', Just newMsg') -> + map ($ (oldMsg', newMsg')) (getEventHandlers @'MessageUpdateEvt eh) + _ -> [] + pure $ rawActions <> actions handleEvent' eh evt@(MessageDelete MessageDeleteData { id }) = do - Just oldMsg <- getMessage id + oldMsg <- getMessage id updateCache evt - pure $ map ($ oldMsg) (getEventHandlers @'MessageDeleteEvt eh) + let rawActions = map ($ id) (getEventHandlers @'RawMessageDeleteEvt eh) + let actions = case oldMsg of + Just oldMsg' -> + map ($ oldMsg') (getEventHandlers @'MessageDeleteEvt eh) + _ -> [] + pure $ rawActions <> actions handleEvent' eh evt@(MessageDeleteBulk MessageDeleteBulkData { ids }) = do messages <- catMaybes <$> traverse getMessage ids updateCache evt - join <$> for messages (\msg -> pure $ map ($ msg) (getEventHandlers @'MessageDeleteEvt eh)) + let rawActions = map ($ ids) (getEventHandlers @'RawMessageDeleteBulkEvt eh) + let actions = map ($ messages) (getEventHandlers @'MessageDeleteBulkEvt eh) + pure $ rawActions <> actions handleEvent' eh evt@(MessageReactionAdd reaction) = do updateCache evt - Just msg <- getMessage (getID reaction) - pure $ map ($ (msg, reaction)) (getEventHandlers @'MessageReactionAddEvt eh) + msg <- getMessage (getID reaction) + let rawActions = map ($ reaction) (getEventHandlers @'RawMessageReactionAddEvt eh) + let actions = case msg of + Just msg' -> + map ($ (msg', reaction)) (getEventHandlers @'MessageReactionAddEvt eh) + _ -> [] + pure $ rawActions <> actions handleEvent' eh evt@(MessageReactionRemove reaction) = do - Just msg <- getMessage (getID reaction) + msg <- getMessage (getID reaction) updateCache evt - pure $ map ($ (msg, reaction)) (getEventHandlers @'MessageReactionRemoveEvt eh) + let rawActions = map ($ reaction) (getEventHandlers @'RawMessageReactionRemoveEvt eh) + let actions = case msg of + Just msg' -> + map ($ (msg', reaction)) (getEventHandlers @'MessageReactionRemoveEvt eh) + _ -> [] + pure $ rawActions <> actions handleEvent' eh evt@(MessageReactionRemoveAll MessageReactionRemoveAllData { messageID }) = do - Just msg <- getMessage messageID + msg <- getMessage messageID updateCache evt - pure $ map ($ msg) (getEventHandlers @'MessageReactionRemoveAllEvt eh) + let rawActions = map ($ messageID) (getEventHandlers @'RawMessageReactionRemoveAllEvt eh) + let actions = case msg of + Just msg' -> + map ($ msg') (getEventHandlers @'MessageReactionRemoveAllEvt eh) + _ -> [] + pure $ rawActions <> actions handleEvent' eh evt@(PresenceUpdate PresenceUpdateData { userID, presence = Presence { guildID } }) = do Just oldGuild <- getGuild guildID diff --git a/src/Calamity/Client/Types.hs b/src/Calamity/Client/Types.hs --- a/src/Calamity/Client/Types.hs +++ b/src/Calamity/Client/Types.hs @@ -22,6 +22,7 @@ import Calamity.Metrics.Eff import Calamity.Types.LogEff import Calamity.Types.Model.Channel +import Calamity.Types.Model.Channel.UpdatedMessage import Calamity.Types.Model.Guild import Calamity.Types.Model.User import Calamity.Types.Token @@ -112,11 +113,43 @@ | InviteDeleteEvt | MessageCreateEvt | MessageUpdateEvt + -- ^ Fired when a cached message is updated, use 'RawMessageUpdateEvt' to see + -- updates of uncached messages + | RawMessageUpdateEvt + -- ^ Fired when a message is updated | MessageDeleteEvt + -- ^ Fired when a cached message is deleted, use 'RawMessageDeleteEvt' to see + -- deletes of uncached messages. + -- + -- Does not include messages deleted through bulk deletes, use + -- 'MessageDeleteBulkEvt' for those + | RawMessageDeleteEvt + -- ^ Fired when a message is deleted. + -- + -- Does not include messages deleted through bulk deletes, use + -- 'RawMessageDeleteBulkEvt' for those | MessageDeleteBulkEvt + -- ^ Fired when messages are bulk deleted. Only includes cached messages, use + -- 'RawMessageDeleteBulkEvt' to see deletes of uncached messages. + | RawMessageDeleteBulkEvt + -- ^ Fired when messages are bulk deleted. | MessageReactionAddEvt + -- ^ Fired when a reaction is added to a cached message, use + -- 'RawMessageReactionAddEvt' to see reactions on uncached messages. + | RawMessageReactionAddEvt + -- ^ Fired when a reaction is added to a message. | MessageReactionRemoveEvt + -- ^ Fired when a reaction is removed from a cached message, use + -- 'RawMessageReactionRemoveEvt' to see reactions on uncached messages. + | RawMessageReactionRemoveEvt + -- ^ Fired when a reaction is removed from a message. | MessageReactionRemoveAllEvt + -- ^ Fired when all reactions are removed from a cached message, use + -- 'RawMessageReactionRemoveEvt' to see reactions on uncached messages. + -- + -- The message passed will contain the removed events. + | RawMessageReactionRemoveAllEvt + -- ^ Fired when all reactions are removed from a message. | TypingStartEvt | UserUpdateEvt | forall s a. CustomEvt s a @@ -165,6 +198,12 @@ EHType 'MessageReactionAddEvt = (Message, Reaction) EHType 'MessageReactionRemoveEvt = (Message, Reaction) EHType 'MessageReactionRemoveAllEvt = Message + EHType 'RawMessageUpdateEvt = UpdatedMessage + EHType 'RawMessageDeleteEvt = Snowflake Message + EHType 'RawMessageDeleteBulkEvt = [Snowflake Message] + EHType 'RawMessageReactionAddEvt = Reaction + EHType 'RawMessageReactionRemoveEvt = Reaction + EHType 'RawMessageReactionRemoveAllEvt = Snowflake Message EHType 'TypingStartEvt = (Channel, Snowflake User, UnixTimestamp) EHType 'UserUpdateEvt = (User, User) EHType ('CustomEvt s a) = a diff --git a/src/Calamity/Commands/Parser.hs b/src/Calamity/Commands/Parser.hs --- a/src/Calamity/Commands/Parser.hs +++ b/src/Calamity/Commands/Parser.hs @@ -21,6 +21,7 @@ import Data.Char ( isSpace ) import Data.Kind import Data.List.NonEmpty ( NonEmpty(..) ) +import Data.Maybe ( isJust ) import Data.Semigroup import qualified Data.Text as S import qualified Data.Text.Lazy as L @@ -312,11 +313,11 @@ partialEmoji :: MonadParsec e L.Text m => m (Partial Emoji) partialEmoji = do - void (chunk "<" *> optional (chunk "a")) + animated <- isJust <$> (chunk "<" *> optional (chunk "a")) name <- between (chunk ":") (chunk ":") (takeWhileP (Just "Emoji name") $ not . (== ':')) id <- snowflake void $ chunk ">" - pure (PartialEmoji id name) + pure (PartialEmoji id name animated) emoji :: MonadParsec e L.Text m => m (Snowflake a) emoji = ping' (optional (chunk "a") *> between (chunk ":") (chunk ":") (void $ takeWhileP Nothing $ not . (== ':'))) diff --git a/src/Calamity/Gateway/DispatchEvents.hs b/src/Calamity/Gateway/DispatchEvents.hs --- a/src/Calamity/Gateway/DispatchEvents.hs +++ b/src/Calamity/Gateway/DispatchEvents.hs @@ -22,7 +22,7 @@ import Data.Text.Lazy ( Text ) import Data.Time import Data.Typeable -import Data.Vector.Unboxed ( Vector ) +import Data.Vector.Unboxing ( Vector ) import GHC.Generics diff --git a/src/Calamity/HTTP/Channel.hs b/src/Calamity/HTTP/Channel.hs --- a/src/Calamity/HTTP/Channel.hs +++ b/src/Calamity/HTTP/Channel.hs @@ -27,6 +27,7 @@ import Data.Generics.Product.Subtype ( upcast ) import Data.Maybe import qualified Data.Text as S +import qualified Data.Text.Encoding as S import Data.Text ( Text ) import GHC.Generics @@ -37,6 +38,7 @@ import Network.Mime import TextShow +import Network.HTTP.Types (urlEncode) data CreateMessageOptions = CreateMessageOptions { content :: Maybe Text @@ -167,6 +169,9 @@ baseRoute id = mkRouteBuilder // S "channels" // ID @Channel & giveID id +encodeEmoji :: RawEmoji -> S.Text +encodeEmoji = S.decodeUtf8 . urlEncode True . S.encodeUtf8 . showt + instance Request (ChannelRequest a) where type Result (ChannelRequest a) = a @@ -184,20 +189,20 @@ & giveID mid & buildRoute route (CreateReaction (getID -> cid) (getID @Message -> mid) emoji) = - baseRoute cid // S "messages" // ID @Message // S "reactions" // S (showt emoji) // S "@me" + baseRoute cid // S "messages" // ID @Message // S "reactions" // S (encodeEmoji emoji) // S "@me" & giveID mid & buildRoute route (DeleteOwnReaction (getID -> cid) (getID @Message -> mid) emoji) = - baseRoute cid // S "messages" // ID @Message // S "reactions" // S (showt emoji) // S "@me" + baseRoute cid // S "messages" // ID @Message // S "reactions" // S (encodeEmoji emoji) // S "@me" & giveID mid & buildRoute route (DeleteUserReaction (getID -> cid) (getID @Message -> mid) emoji (getID @User -> uid)) = - baseRoute cid // S "messages" // ID @Message // S "reactions" // S (showt emoji) // ID @User + baseRoute cid // S "messages" // ID @Message // S "reactions" // S (encodeEmoji emoji) // ID @User & giveID mid & giveID uid & buildRoute route (GetReactions (getID -> cid) (getID @Message -> mid) emoji _) = - baseRoute cid // S "messages" // ID @Message // S "reactions" // S (showt emoji) + baseRoute cid // S "messages" // ID @Message // S "reactions" // S (encodeEmoji emoji) & giveID mid & buildRoute route (DeleteAllReactions (getID -> cid) (getID @Message -> mid)) = diff --git a/src/Calamity/HTTP/Emoji.hs b/src/Calamity/HTTP/Emoji.hs --- a/src/Calamity/HTTP/Emoji.hs +++ b/src/Calamity/HTTP/Emoji.hs @@ -17,7 +17,6 @@ import GHC.Generics -import Network.Wreq.Lens import Network.Wreq.Session diff --git a/src/Calamity/Internal/AesonThings.hs b/src/Calamity/Internal/AesonThings.hs --- a/src/Calamity/Internal/AesonThings.hs +++ b/src/Calamity/Internal/AesonThings.hs @@ -137,3 +137,4 @@ jsonOptionsKeepNothing = defaultOptions { sumEncoding = UntaggedValue , fieldLabelModifier = camelTo2 '_' . filter (/= '_') , omitNothingFields = False } + diff --git a/src/Calamity/Internal/Utils.hs b/src/Calamity/Internal/Utils.hs --- a/src/Calamity/Internal/Utils.hs +++ b/src/Calamity/Internal/Utils.hs @@ -27,8 +27,9 @@ import Data.Semigroup ( Last(..) ) import Data.Text.Lazy import Data.Time -import qualified Data.Vector.Unboxed as VU -import Data.Vector.Unboxed ( Vector ) +import qualified Data.Vector.Unboxing as VU +import Data.Vector.Unboxing ( Vector ) +import Data.Aeson import qualified DiPolysemy as Di @@ -93,7 +94,7 @@ instance TextShow UTCTime where showb = fromString . show -instance (TextShow a, VU.Unbox a) => TextShow (Vector a) where +instance (TextShow a, VU.Unboxable a) => TextShow (Vector a) where showb = showbList . VU.toList instance (Show k, Show v) => TextShow (LH.HashMap k v) where @@ -106,4 +107,11 @@ showb = fromString . show instance Default (M.Map k v) where - def = M.empty + def = M.empty + +instance (FromJSON a, VU.Unboxable a) => FromJSON (VU.Vector a) where + parseJSON = (VU.fromList <$>) . parseJSON + +instance (ToJSON a, VU.Unboxable a) => ToJSON (VU.Vector a) where + toJSON = toJSON . VU.toList + toEncoding = toEncoding . VU.toList diff --git a/src/Calamity/Types/Model/Channel/DM.hs b/src/Calamity/Types/Model/Channel/DM.hs --- a/src/Calamity/Types/Model/Channel/DM.hs +++ b/src/Calamity/Types/Model/Channel/DM.hs @@ -11,7 +11,7 @@ import Data.Aeson import Data.Time -import Data.Vector.Unboxed ( Vector ) +import Data.Vector.Unboxing ( Vector ) import GHC.Generics diff --git a/src/Calamity/Types/Model/Channel/Group.hs b/src/Calamity/Types/Model/Channel/Group.hs --- a/src/Calamity/Types/Model/Channel/Group.hs +++ b/src/Calamity/Types/Model/Channel/Group.hs @@ -12,7 +12,7 @@ import Data.Aeson import Data.Text.Lazy ( Text ) import Data.Time -import Data.Vector.Unboxed ( Vector ) +import Data.Vector.Unboxing ( Vector ) import GHC.Generics diff --git a/src/Calamity/Types/Model/Channel/Message.hs b/src/Calamity/Types/Model/Channel/Message.hs --- a/src/Calamity/Types/Model/Channel/Message.hs +++ b/src/Calamity/Types/Model/Channel/Message.hs @@ -15,7 +15,7 @@ import Data.Scientific import Data.Text.Lazy ( Text ) import Data.Time -import qualified Data.Vector.Unboxed as UV +import qualified Data.Vector.Unboxing as UV import GHC.Generics diff --git a/src/Calamity/Types/Model/Channel/UpdatedMessage.hs b/src/Calamity/Types/Model/Channel/UpdatedMessage.hs --- a/src/Calamity/Types/Model/Channel/UpdatedMessage.hs +++ b/src/Calamity/Types/Model/Channel/UpdatedMessage.hs @@ -13,7 +13,7 @@ import Data.Aeson import Data.Text.Lazy ( Text ) import Data.Time -import qualified Data.Vector.Unboxed as UV +import qualified Data.Vector.Unboxing as UV import GHC.Generics diff --git a/src/Calamity/Types/Model/Guild/Emoji.hs b/src/Calamity/Types/Model/Guild/Emoji.hs --- a/src/Calamity/Types/Model/Guild/Emoji.hs +++ b/src/Calamity/Types/Model/Guild/Emoji.hs @@ -2,7 +2,8 @@ module Calamity.Types.Model.Guild.Emoji ( Emoji(..) , Partial(PartialEmoji) - , RawEmoji(..) ) where + , RawEmoji(..) + , emojiAsRawEmoji ) where import Calamity.Internal.AesonThings import Calamity.Internal.Utils () @@ -11,13 +12,15 @@ import Calamity.Types.Snowflake import Data.Aeson +import qualified Data.Text.Lazy as L import Data.Text.Lazy ( Text ) -import Data.Vector.Unboxed ( Vector ) +import Data.Vector.Unboxing ( Vector ) import GHC.Generics import TextShow import qualified TextShow.Generic as TSG +import Data.Generics.Product data Emoji = Emoji { id :: Snowflake Emoji @@ -34,21 +37,43 @@ deriving ( FromJSON ) via WithSpecialCases '["user" `ExtractFieldFrom` "id"] Emoji deriving ( HasID Emoji ) via HasIDField "id" Emoji +emojiAsRawEmoji :: Emoji -> RawEmoji +emojiAsRawEmoji = CustomEmoji . upcast + data instance Partial Emoji = PartialEmoji { id :: Snowflake Emoji , name :: Text + , animated :: Bool } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric (Partial Emoji) - deriving ( ToJSON, FromJSON ) via CalamityJSON (Partial Emoji) + deriving ( Eq, Generic ) + deriving ( ToJSON ) via CalamityJSON (Partial Emoji) + deriving ( FromJSON ) via WithSpecialCases + '["animated" `IfNoneThen` DefaultToFalse] (Partial Emoji) deriving ( HasID Emoji ) via HasIDField "id" (Partial Emoji) +instance Show (Partial Emoji) where + show PartialEmoji { id, name, animated } = + "<" <> a <> ":" <> L.unpack name <> ":" <> show id <> ">" + where a = if animated then "a" else "" + +instance TextShow (Partial Emoji) where + showb PartialEmoji { id, name, animated } = + "<" <> a <> ":" <> fromLazyText name <> ":" <> showb id <> ">" + where a = if animated then "a" else "" + data RawEmoji = UnicodeEmoji Text | CustomEmoji (Partial Emoji) - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric RawEmoji + deriving ( Eq, Generic ) +instance Show RawEmoji where + show (UnicodeEmoji v) = L.unpack v + show (CustomEmoji p) = show p + +instance TextShow RawEmoji where + showb (UnicodeEmoji v) = fromLazyText v + showb (CustomEmoji p) = showb p + instance ToJSON RawEmoji where toJSON (CustomEmoji e) = object ["emoji" .= e] toJSON (UnicodeEmoji s) = object ["emoji" .= object ["name" .= s]] @@ -56,8 +81,9 @@ instance FromJSON RawEmoji where parseJSON = withObject "RawEmoji" $ \v -> do m_id :: Maybe (Snowflake Emoji) <- v .:? "id" + anim <- v .:? "animated" .!= False name :: Text <- v .: "name" pure $ case m_id of - Just id -> CustomEmoji $ PartialEmoji id name + Just id -> CustomEmoji $ PartialEmoji id name anim Nothing -> UnicodeEmoji name diff --git a/src/Calamity/Types/Model/Guild/Member.hs b/src/Calamity/Types/Model/Guild/Member.hs --- a/src/Calamity/Types/Model/Guild/Member.hs +++ b/src/Calamity/Types/Model/Guild/Member.hs @@ -13,7 +13,7 @@ import Data.Aeson import Data.Text.Lazy ( Text ) import Data.Time -import Data.Vector.Unboxed ( Vector ) +import Data.Vector.Unboxing ( Vector ) import GHC.Generics diff --git a/src/Calamity/Types/Snowflake.hs b/src/Calamity/Types/Snowflake.hs --- a/src/Calamity/Types/Snowflake.hs +++ b/src/Calamity/Types/Snowflake.hs @@ -10,7 +10,6 @@ import Control.DeepSeq import Control.Lens -import Control.Monad import Data.Aeson import Data.Data @@ -18,9 +17,7 @@ import Data.Hashable import Data.Kind import Data.Text.Read -import qualified Data.Vector.Generic.Base as V -import qualified Data.Vector.Generic.Mutable as MV -import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxing as U import Data.Word import GHC.Generics @@ -34,7 +31,7 @@ } deriving ( Generic, Eq, Ord, Data ) deriving ( Show, TextShow ) via Word64 - deriving newtype ( NFData, ToJSONKey, Hashable ) + deriving newtype ( NFData, ToJSONKey, Hashable, U.Unboxable ) instance ToJSON (Snowflake t) where toJSON (Snowflake s) = String . showt $ s @@ -74,69 +71,3 @@ instance HasID a (Snowflake a) where getID = id - -newtype instance U.MVector s (Snowflake t) = MV_Snowflake (U.MVector s Word64) - -newtype instance U.Vector (Snowflake t) = V_Snowflake (U.Vector Word64) - -instance MV.MVector U.MVector (Snowflake t) where - {-# INLINE basicLength #-} - {-# INLINE basicUnsafeSlice #-} - {-# INLINE basicOverlaps #-} - {-# INLINE basicUnsafeNew #-} - {-# INLINE basicInitialize #-} - {-# INLINE basicUnsafeReplicate #-} - {-# INLINE basicUnsafeRead #-} - {-# INLINE basicUnsafeWrite #-} - {-# INLINE basicClear #-} - {-# INLINE basicSet #-} - {-# INLINE basicUnsafeCopy #-} - {-# INLINE basicUnsafeGrow #-} - basicLength (MV_Snowflake v) = MV.basicLength v - - basicUnsafeSlice i n (MV_Snowflake v) = MV_Snowflake $ MV.basicUnsafeSlice i n v - - basicOverlaps (MV_Snowflake v1) (MV_Snowflake v2) = MV.basicOverlaps v1 v2 - - basicUnsafeNew n = MV_Snowflake `liftM` MV.basicUnsafeNew n - - basicInitialize (MV_Snowflake v) = MV.basicInitialize v - - basicUnsafeReplicate n x = MV_Snowflake `liftM` MV.basicUnsafeReplicate n (fromSnowflake x) - - basicUnsafeRead (MV_Snowflake v) i = Snowflake `liftM` MV.basicUnsafeRead v i - - basicUnsafeWrite (MV_Snowflake v) i x = MV.basicUnsafeWrite v i (fromSnowflake x) - - basicClear (MV_Snowflake v) = MV.basicClear v - - basicSet (MV_Snowflake v) x = MV.basicSet v (fromSnowflake x) - - basicUnsafeCopy (MV_Snowflake v1) (MV_Snowflake v2) = MV.basicUnsafeCopy v1 v2 - - basicUnsafeMove (MV_Snowflake v1) (MV_Snowflake v2) = MV.basicUnsafeMove v1 v2 - - basicUnsafeGrow (MV_Snowflake v) n = MV_Snowflake `liftM` MV.basicUnsafeGrow v n - -instance V.Vector U.Vector (Snowflake t) where - {-# INLINE basicUnsafeFreeze #-} - {-# INLINE basicUnsafeThaw #-} - {-# INLINE basicLength #-} - {-# INLINE basicUnsafeSlice #-} - {-# INLINE basicUnsafeIndexM #-} - {-# INLINE elemseq #-} - basicUnsafeFreeze (MV_Snowflake v) = V_Snowflake `liftM` V.basicUnsafeFreeze v - - basicUnsafeThaw (V_Snowflake v) = MV_Snowflake `liftM` V.basicUnsafeThaw v - - basicLength (V_Snowflake v) = V.basicLength v - - basicUnsafeSlice i n (V_Snowflake v) = V_Snowflake $ V.basicUnsafeSlice i n v - - basicUnsafeIndexM (V_Snowflake v) i = Snowflake `liftM` V.basicUnsafeIndexM v i - - basicUnsafeCopy (MV_Snowflake mv) (V_Snowflake v) = V.basicUnsafeCopy mv v - - elemseq _ = seq - -instance U.Unbox (Snowflake t) diff --git a/src/Calamity/Utils/Permissions.hs b/src/Calamity/Utils/Permissions.hs --- a/src/Calamity/Utils/Permissions.hs +++ b/src/Calamity/Utils/Permissions.hs @@ -18,7 +18,7 @@ import Control.Lens import Data.Flags -import qualified Data.Vector.Unboxed as V +import qualified Data.Vector.Unboxing as V import qualified Polysemy as P import Data.Foldable (Foldable(foldl'))