diff --git a/Calamity/Cache/Eff.hs b/Calamity/Cache/Eff.hs --- a/Calamity/Cache/Eff.hs +++ b/Calamity/Cache/Eff.hs @@ -102,17 +102,17 @@ makeSem ''CacheEff -updateBotUser :: P.Member CacheEff r => (User -> User) -> Sem r () +updateBotUser :: (P.Member CacheEff r) => (User -> User) -> Sem r () updateBotUser f = getBotUser >>= flip whenJust (setBotUser . f) -updateGuild :: P.Member CacheEff r => Snowflake Guild -> (Guild -> Guild) -> Sem r () +updateGuild :: (P.Member CacheEff r) => Snowflake Guild -> (Guild -> Guild) -> Sem r () updateGuild id f = getGuild id >>= flip whenJust (setGuild . f) -updateDM :: P.Member CacheEff r => Snowflake DMChannel -> (DMChannel -> DMChannel) -> Sem r () +updateDM :: (P.Member CacheEff r) => Snowflake DMChannel -> (DMChannel -> DMChannel) -> Sem r () updateDM id f = getDM id >>= flip whenJust (setDM . f) -updateUser :: P.Member CacheEff r => Snowflake User -> (User -> User) -> Sem r () +updateUser :: (P.Member CacheEff r) => Snowflake User -> (User -> User) -> Sem r () updateUser id f = getUser id >>= flip whenJust (setUser . f) -updateMessage :: P.Member CacheEff r => Snowflake Message -> (Message -> Message) -> Sem r () +updateMessage :: (P.Member CacheEff r) => Snowflake Message -> (Message -> Message) -> Sem r () updateMessage id f = getMessage id >>= flip whenJust (setMessage . f) diff --git a/Calamity/Cache/InMemory.hs b/Calamity/Cache/InMemory.hs --- a/Calamity/Cache/InMemory.hs +++ b/Calamity/Cache/InMemory.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} -- | A 'Cache' handler that operates in memory module Calamity.Cache.InMemory ( @@ -53,19 +54,19 @@ emptyCache' msgLimit = Cache Nothing SM.empty SM.empty SH.empty SM.empty HS.empty (Identity $ BS.empty msgLimit) -- | Run the cache in memory with a default message cache size of 1000 -runCacheInMemory :: P.Member (P.Embed IO) r => P.Sem (CacheEff ': r) a -> P.Sem r a +runCacheInMemory :: (P.Member (P.Embed IO) r) => P.Sem (CacheEff ': r) a -> P.Sem r a runCacheInMemory m = do var <- P.embed $ newIORef emptyCache P.runAtomicStateIORef var $ P.reinterpret runCache' m -- | Run the cache in memory with no messages being cached -runCacheInMemoryNoMsg :: P.Member (P.Embed IO) r => P.Sem (CacheEff ': r) a -> P.Sem r a +runCacheInMemoryNoMsg :: (P.Member (P.Embed IO) r) => P.Sem (CacheEff ': r) a -> P.Sem r a runCacheInMemoryNoMsg m = do var <- P.embed $ newIORef emptyCacheNoMsg P.runAtomicStateIORef var $ P.reinterpret runCache' m -- | Run the cache in memory with a configurable message cache limit -runCacheInMemory' :: P.Member (P.Embed IO) r => Int -> P.Sem (CacheEff ': r) a -> P.Sem r a +runCacheInMemory' :: (P.Member (P.Embed IO) r) => Int -> P.Sem (CacheEff ': r) a -> P.Sem r a runCacheInMemory' msgLimit m = do var <- P.embed $ newIORef (emptyCache' msgLimit) P.runAtomicStateIORef var $ P.reinterpret runCache' m @@ -91,7 +92,7 @@ getMessages' = pure [] delMessage' !_ = pure () -runCache :: MessageMod (Cache t) => CacheEff m a -> State (Cache t) a +runCache :: (MessageMod (Cache t)) => CacheEff m a -> State (Cache t) a runCache (SetBotUser u) = #user ?= u runCache GetBotUser = use #user runCache (SetGuild g) = do diff --git a/Calamity/Client/Client.hs b/Calamity/Client/Client.hs --- a/Calamity/Client/Client.hs +++ b/Calamity/Client/Client.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} -- | The client module Calamity.Client.Client ( @@ -65,7 +66,7 @@ import Polysemy.Resource qualified as P import TextShow (TextShow (showt)) -timeA :: P.Member (P.Embed IO) r => P.Sem r a -> P.Sem r (Double, a) +timeA :: (P.Member (P.Embed IO) r) => P.Sem r a -> P.Sem r (Double, a) timeA m = do start <- P.embed getPOSIXTime res <- m @@ -103,19 +104,19 @@ P.Sem r (Maybe StartupError) runBotIO token intents = runBotIO' token intents Nothing -resetDi :: BotC r => P.Sem r a -> P.Sem r a +resetDi :: (BotC r) => P.Sem r a -> P.Sem r a resetDi m = do initialDi <- P.asks (^. #initialDi) Di.local (`fromMaybe` initialDi) m -interpretRatelimitViaClient :: P.Member (P.Reader Client) r => P.Sem (RatelimitEff ': r) a -> P.Sem r a +interpretRatelimitViaClient :: (P.Member (P.Reader Client) r) => P.Sem (RatelimitEff ': r) a -> P.Sem r a interpretRatelimitViaClient = P.interpret ( \case GetRatelimitState -> P.asks (^. #rlState) ) -interpretTokenViaClient :: P.Member (P.Reader Client) r => P.Sem (TokenEff ': r) a -> P.Sem r a +interpretTokenViaClient :: (P.Member (P.Reader Client) r) => P.Sem (TokenEff ': r) a -> P.Sem r a interpretTokenViaClient = P.interpret ( \case @@ -246,7 +247,7 @@ 'fire' '$' 'customEvt' @"my-event" ("aha" :: 'Data.Text.Text', msg) @ -} -fire :: BotC r => CalamityEvent -> P.Sem r () +fire :: (BotC r) => CalamityEvent -> P.Sem r () fire e = do inc <- P.asks (^. #eventsIn) P.embed $ writeChan inc e @@ -261,11 +262,11 @@ 'customEvt' (MyCustomEvent "lol") @ -} -customEvt :: forall a. Typeable a => a -> CalamityEvent +customEvt :: forall a. (Typeable a) => a -> CalamityEvent customEvt = Custom -- | Get a copy of the event stream. -events :: BotC r => P.Sem r (OutChan CalamityEvent) +events :: (BotC r) => P.Sem r (OutChan CalamityEvent) events = do inc <- P.asks (^. #eventsIn) P.embed $ dupChan inc @@ -356,20 +357,20 @@ P.embed $ putMVar result args -- | Set the bot's presence on all shards. -sendPresence :: BotC r => StatusUpdateData -> P.Sem r () +sendPresence :: (BotC r) => StatusUpdateData -> P.Sem r () sendPresence s = do shards <- P.asks (^. #shards) >>= P.embed . readTVarIO for_ shards $ \(inc, _) -> P.embed $ writeChan inc (SendPresence s) -- | Initiate shutting down the bot. -stopBot :: BotC r => P.Sem r () +stopBot :: (BotC r) => P.Sem r () stopBot = do debug "stopping bot" inc <- P.asks (^. #eventsIn) P.embed $ writeChan inc ShutDown -finishUp :: BotC r => P.Sem r () +finishUp :: (BotC r) => P.Sem r () finishUp = do debug "finishing up" shards <- P.asks (^. #shards) >>= P.embed . readTVarIO @@ -381,7 +382,7 @@ {- | main loop of the client, handles fetching the next event, processing the event and invoking its handler functions -} -clientLoop :: BotC r => P.Sem r () +clientLoop :: (BotC r) => P.Sem r () clientLoop = do outc <- P.asks (^. #eventsOut) whileMFinalIO $ do @@ -400,14 +401,14 @@ for_ handlers (\h -> P.async . P.embed $ h d) -catchAllLogging :: BotC r => P.Sem r () -> P.Sem r () +catchAllLogging :: (BotC r) => P.Sem r () -> P.Sem r () catchAllLogging m = do r <- P.errorToIOFinal . P.fromExceptionSem @SomeException $ P.raise m case r of Right _ -> pure () Left e -> debug . T.pack $ "got exception: " <> show e -handleEvent :: BotC r => Int -> DispatchData -> P.Sem r () +handleEvent :: (BotC r) => Int -> DispatchData -> P.Sem r () handleEvent shardID data' = do debug . T.pack $ "handling an event: " <> ctorName data' eventHandlers <- P.atomicGet @@ -429,7 +430,7 @@ Left err -> debug . T.pack $ "Failed handling actions for event: " <> show err handleEvent' :: - BotC r => + (BotC r) => EventHandlers -> DispatchData -> P.Sem (P.Fail ': r) [IO ()] @@ -667,7 +668,7 @@ pure [] handleEvent' _ e = fail $ "Unhandled event: " <> show e -updateCache :: P.Members '[CacheEff, P.Fail] r => DispatchData -> P.Sem r () +updateCache :: (P.Members '[CacheEff, P.Fail] r) => DispatchData -> P.Sem r () updateCache (Ready ReadyData {user, guilds}) = do setBotUser user for_ (map getID guilds) setUnavailableGuild @@ -738,8 +739,11 @@ (getID reaction) ( \m -> m - & #reactions % traversed %~ updateReactionRemove isMe (reaction ^. #emoji) - & #reactions %~ filter (\r -> r ^. #count /= 0) + & #reactions + % traversed + %~ updateReactionRemove isMe (reaction ^. #emoji) + & #reactions + %~ filter (\r -> r ^. #count /= 0) ) updateCache (MessageReactionRemoveAll MessageReactionRemoveAllData {messageID}) = updateMessage messageID (#reactions .~ mempty) @@ -780,8 +784,10 @@ if emoji == reaction ^. #emoji then reaction - & #count %~ succ - & #me %~ (|| isMe) + & #count + %~ succ + & #me + %~ (|| isMe) else reaction updateReactionRemove :: Bool -> RawEmoji -> Reaction -> Reaction @@ -789,6 +795,8 @@ if emoji == reaction ^. #emoji then reaction - & #count %~ pred - & #me %~ (&& not isMe) + & #count + %~ pred + & #me + %~ (&& not isMe) else reaction diff --git a/Calamity/Client/ShardManager.hs b/Calamity/Client/ShardManager.hs --- a/Calamity/Client/ShardManager.hs +++ b/Calamity/Client/ShardManager.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + -- | Contains stuff for managing shards module Calamity.Client.ShardManager (shardBot) where @@ -21,7 +23,7 @@ mapLeft _ (Right b) = Right b -- | Connects the bot to the gateway over n shards -shardBot :: BotC r => Maybe StatusUpdateData -> Intents -> Sem r (Either StartupError ()) +shardBot :: (BotC r) => Maybe StatusUpdateData -> Intents -> Sem r (Either StartupError ()) shardBot initialStatus intents = (mapLeft StartupError <$>) . P.runFail $ do numShardsVar <- P.asks numShards shardsVar <- P.asks shards diff --git a/Calamity/Client/Types.hs b/Calamity/Client/Types.hs --- a/Calamity/Client/Types.hs +++ b/Calamity/Client/Types.hs @@ -375,7 +375,7 @@ (\(EH ehs) -> EH $ filter ((/= id') . ehID) ehs) handlers -getCustomEventHandlers :: forall a. Typeable a => EventHandlers -> [a -> IO ()] +getCustomEventHandlers :: forall a. (Typeable a) => EventHandlers -> [a -> IO ()] getCustomEventHandlers (EventHandlers handlers) = let handlerMap = unwrapEventHandler @('CustomEvt Void) $ diff --git a/Calamity/Commands/CalamityParsers.hs b/Calamity/Commands/CalamityParsers.hs --- a/Calamity/Commands/CalamityParsers.hs +++ b/Calamity/Commands/CalamityParsers.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} -- | 'ParameterParser' instances for calamity models module Calamity.Commands.CalamityParsers () where @@ -24,12 +25,12 @@ import Text.Megaparsec.Char.Lexer (decimal) import Text.Megaparsec.Error.Builder (errFancy, fancy) -parserName :: forall a c r. ParameterParser a c r => T.Text +parserName :: forall a c r. (ParameterParser a c r) => T.Text parserName = let ParameterInfo (fromMaybe "" -> name) type_ _ = parameterInfo @a @c @r in name <> ":" <> T.pack (show type_) -instance Typeable (Snowflake a) => ParameterParser (Snowflake a) c r where +instance (Typeable (Snowflake a)) => ParameterParser (Snowflake a) c r where parse = parseMP (parserName @(Snowflake a)) snowflake parameterDescription = "discord id" @@ -88,7 +89,7 @@ 'User'@ and use 'Calamity.Types.Upgradeable.upgrade' if you want to allow fetching from http. -} -instance P.Member CacheEff r => ParameterParser User c r where +instance (P.Member CacheEff r) => ParameterParser User c r where parse = parseMP (parserName @User @c @r) $ mapParserMaybeM @@ -118,7 +119,7 @@ and use 'Calamity.Types.Upgradeable.upgrade' if you want to allow fetching from http. -} -instance P.Member CacheEff r => ParameterParser Guild c r where +instance (P.Member CacheEff r) => ParameterParser Guild c r where parse = parseMP (parserName @Guild @c @r) $ mapParserMaybeM @@ -171,16 +172,16 @@ -- skipN :: (Stream s, Ord e) => Int -> ParsecT e s m () -- skipN n = void $ takeP Nothing n -ping :: MonadParsec e T.Text m => T.Text -> m (Snowflake a) +ping :: (MonadParsec e T.Text m) => T.Text -> m (Snowflake a) ping c = chunk ("<" <> c) *> optional (chunk "!") *> snowflake <* chunk ">" -ping' :: MonadParsec e T.Text m => m () -> m (Snowflake a) +ping' :: (MonadParsec e T.Text m) => m () -> m (Snowflake a) ping' m = chunk "<" *> m *> snowflake <* chunk ">" -snowflake :: MonadParsec e T.Text m => m (Snowflake a) +snowflake :: (MonadParsec e T.Text m) => m (Snowflake a) snowflake = Snowflake <$> decimal -partialEmoji :: MonadParsec e T.Text m => m (Partial Emoji) +partialEmoji :: (MonadParsec e T.Text m) => m (Partial Emoji) partialEmoji = do animated <- isJust <$> (chunk "<" *> optional (chunk "a")) name <- between (chunk ":") (chunk ":") (takeWhileP (Just "Emoji name") (/= ':')) @@ -188,7 +189,7 @@ void $ chunk ">" pure (PartialEmoji id name animated) -emoji :: MonadParsec e T.Text m => m (Snowflake a) +emoji :: (MonadParsec e T.Text m) => m (Snowflake a) emoji = ping' (optional (chunk "a") *> between (chunk ":") (chunk ":") (void $ takeWhileP Nothing (/= ':'))) -- trackOffsets :: MonadParsec e s m => m a -> m (a, Int) diff --git a/Calamity/Commands/Context.hs b/Calamity/Commands/Context.hs --- a/Calamity/Commands/Context.hs +++ b/Calamity/Commands/Context.hs @@ -26,7 +26,7 @@ import Polysemy.Fail qualified as P import TextShow qualified -class CommandContext c => CalamityCommandContext c where +class (CommandContext c) => CalamityCommandContext c where -- | The id of the channel that invoked this command ctxChannelID :: c -> Snowflake Channel @@ -83,14 +83,14 @@ instance Tellable FullContext where getChannel = pure . ctxChannelID -useFullContext :: P.Member CacheEff r => P.Sem (CC.ConstructContext (Message, User, Maybe Member) FullContext IO () ': r) a -> P.Sem r a +useFullContext :: (P.Member CacheEff r) => P.Sem (CC.ConstructContext (Message, User, Maybe Member) FullContext IO () ': r) a -> P.Sem r a useFullContext = P.interpret ( \case CC.ConstructContext (pre, cmd, up) (msg, usr, mem) -> buildContext msg usr mem pre cmd up ) -buildContext :: P.Member CacheEff r => Message -> User -> Maybe Member -> T.Text -> Command FullContext -> T.Text -> P.Sem r (Maybe FullContext) +buildContext :: (P.Member CacheEff r) => Message -> User -> Maybe Member -> T.Text -> Command FullContext -> T.Text -> P.Sem r (Maybe FullContext) buildContext msg usr mem prefix command unparsed = (rightToMaybe <$>) . P.runFail $ do guild <- join <$> getGuild `traverse` (msg ^. #guildID) let member = mem <|> guild ^? _Just % #members % ix (coerceSnowflake $ getID @User msg) diff --git a/Calamity/Commands/Dsl.hs b/Calamity/Commands/Dsl.hs --- a/Calamity/Commands/Dsl.hs +++ b/Calamity/Commands/Dsl.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + {- | A DSL for generating commands and groups This is effectively just a re-export of "CalamityCommands.Dsl" but with @@ -203,14 +205,14 @@ action to hidden. -} hide :: - P.Member (P.Tagged "hidden" (P.Reader Bool)) r => + (P.Member (P.Tagged "hidden" (P.Reader Bool)) r) => P.Sem r a -> P.Sem r a hide = CC.hide -- | Set the help for any groups or commands registered inside the given action. help :: - P.Member (P.Reader (c -> T.Text)) r => + (P.Member (P.Reader (c -> T.Text)) r) => (c -> T.Text) -> P.Sem r a -> P.Sem r a @@ -220,7 +222,7 @@ action. -} requires :: - DSLC c r => + (DSLC c r) => [Check c] -> P.Sem r a -> P.Sem r a @@ -247,7 +249,7 @@ Refer to 'CalamityCommands.Check.Check' for more info on checks. -} requiresPure :: - DSLC c r => + (DSLC c r) => [(T.Text, c -> Maybe T.Text)] -> -- A list of check names and check callbacks P.Sem r a -> @@ -324,5 +326,5 @@ groupA' = CC.groupA' -- | Retrieve the final command handler for this block -fetchHandler :: DSLC c r => P.Sem r (CommandHandler c) +fetchHandler :: (DSLC c r) => P.Sem r (CommandHandler c) fetchHandler = P.ask diff --git a/Calamity/Gateway/DispatchEvents.hs b/Calamity/Gateway/DispatchEvents.hs --- a/Calamity/Gateway/DispatchEvents.hs +++ b/Calamity/Gateway/DispatchEvents.hs @@ -30,12 +30,12 @@ data CalamityEvent = Dispatch + -- | The shard that pushed this event Int - -- ^ The shard that pushed this event + -- | The attached data DispatchData - -- ^ The attached data | -- | The data sent to the custom event - forall (a :: Type). Typeable a => Custom a + forall (a :: Type). (Typeable a) => Custom a | ShutDown data DispatchData diff --git a/Calamity/Gateway/Shard.hs b/Calamity/Gateway/Shard.hs --- a/Calamity/Gateway/Shard.hs +++ b/Calamity/Gateway/Shard.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + -- | The shard logic module Calamity.Gateway.Shard ( Shard (..), @@ -109,7 +111,7 @@ import Prelude hiding (error) runWebsocket :: - P.Members '[LogEff, P.Final IO, P.Embed IO] r => + (P.Members '[LogEff, P.Final IO, P.Embed IO] r) => T.Text -> T.Text -> (Connection -> P.Sem r a) -> @@ -155,7 +157,7 @@ -- | Creates and launches a shard newShard :: - P.Members '[LogEff, MetricEff, P.Embed IO, P.Final IO, P.Async] r => + (P.Members '[LogEff, MetricEff, P.Embed IO, P.Final IO, P.Async] r) => T.Text -> Int -> Int -> @@ -176,7 +178,7 @@ pure (cmdIn, thread') -sendToWs :: ShardC r => SentDiscordMessage -> Sem r () +sendToWs :: (ShardC r) => SentDiscordMessage -> Sem r () sendToWs data' = do wsConn' <- P.atomicGets wsConn case wsConn' of @@ -194,14 +196,14 @@ Just True -> pure True Nothing -> pure False -restartUnless :: P.Members '[LogEff, P.Error ShardFlowControl] r => T.Text -> Maybe a -> P.Sem r a +restartUnless :: (P.Members '[LogEff, P.Error ShardFlowControl] r) => T.Text -> Maybe a -> P.Sem r a restartUnless _ (Just a) = pure a restartUnless msg Nothing = do error msg P.throw ShardFlowRestart -- | The loop a shard will run on -shardLoop :: ShardC r => Sem r () +shardLoop :: (ShardC r) => Sem r () shardLoop = do activeShards <- registerGauge "active_shards" mempty void $ modifyGauge (+ 1) activeShards @@ -225,7 +227,7 @@ Left (ShutDownShard, Just . showt $ code) e -> Left (RestartShard, Just . T.pack . show $ e) - discordStream :: P.Members '[LogEff, MetricEff, P.Embed IO, P.Final IO] r => Connection -> TBMQueue ShardMsg -> Sem r () + discordStream :: (P.Members '[LogEff, MetricEff, P.Embed IO, P.Final IO] r) => Connection -> TBMQueue ShardMsg -> Sem r () discordStream ws outqueue = inner where inner = do @@ -245,7 +247,7 @@ error . T.pack $ "Failed to decode " <> e <> ": " <> show msg' pure True when r inner - outerloop :: ShardC r => Sem r () + outerloop :: (ShardC r) => Sem r () outerloop = whileMFinalIO $ do shard :: Shard <- P.atomicGets (^. #shardS) let host = shard ^. #gateway @@ -268,7 +270,7 @@ info "Restarting shard (abnormal reasons?)" pure True - innerloop :: ShardC r => Connection -> Sem r ShardFlowControl + innerloop :: (ShardC r) => Connection -> Sem r ShardFlowControl innerloop ws = do debug "Entering inner loop of shard" @@ -370,13 +372,13 @@ RestartShard -> P.throw ShardFlowRestart ShutDownShard -> P.throw ShardFlowShutDown -startHeartBeatLoop :: ShardC r => Int -> Sem r () +startHeartBeatLoop :: (ShardC r) => Int -> Sem r () startHeartBeatLoop interval = do haltHeartBeat -- cancel any currently running hb thread thread <- P.async $ heartBeatLoop interval P.atomicModify' (#hbThread ?~ thread) -haltHeartBeat :: ShardC r => Sem r () +haltHeartBeat :: (ShardC r) => Sem r () haltHeartBeat = do thread <- P.atomicState @ShardState . (swap .) . runState $ do thread <- use #hbThread @@ -388,14 +390,14 @@ P.embed (void $ cancel t) Nothing -> pure () -sendHeartBeat :: ShardC r => Sem r () +sendHeartBeat :: (ShardC r) => Sem r () sendHeartBeat = do sn <- P.atomicGets (^. #seqNum) debug . T.pack $ "Sending heartbeat (seq: " <> show sn <> ")" sendToWs $ HeartBeat sn P.atomicModify' (#hbResponse .~ False) -heartBeatLoop :: ShardC r => Int -> Sem r () +heartBeatLoop :: (ShardC r) => Int -> Sem r () heartBeatLoop interval = untilJustFinalIO . (leftToMaybe <$>) . P.runError $ do sendHeartBeat P.embed . threadDelay $ interval * 1000 diff --git a/Calamity/HTTP/AuditLog.hs b/Calamity/HTTP/AuditLog.hs --- a/Calamity/HTTP/AuditLog.hs +++ b/Calamity/HTTP/AuditLog.hs @@ -24,7 +24,7 @@ def = GetAuditLogOptions Nothing Nothing Nothing Nothing data AuditLogRequest a where - GetAuditLog :: HasID Guild g => g -> GetAuditLogOptions -> AuditLogRequest AuditLog + GetAuditLog :: (HasID Guild g) => g -> GetAuditLogOptions -> AuditLogRequest AuditLog instance Request (AuditLogRequest a) where type Result (AuditLogRequest a) = a diff --git a/Calamity/HTTP/Channel.hs b/Calamity/HTTP/Channel.hs --- a/Calamity/HTTP/Channel.hs +++ b/Calamity/HTTP/Channel.hs @@ -320,8 +320,10 @@ baseRoute :: Snowflake Channel -> RouteBuilder _ baseRoute id = - mkRouteBuilder // S "channels" // ID @Channel - & giveID id + mkRouteBuilder + // S "channels" + // ID @Channel + & giveID id renderEmoji :: RawEmoji -> Text renderEmoji (UnicodeEmoji e) = e @@ -331,12 +333,15 @@ type Result (ChannelRequest a) = a route (CreateMessage (getID -> id) _) = - baseRoute id // S "messages" - & buildRoute + baseRoute id + // S "messages" + & buildRoute route (CrosspostMessage (getID -> id) (getID @Message -> mid)) = - baseRoute id // S "messages" // ID @Message - & giveID mid - & buildRoute + baseRoute id + // S "messages" + // ID @Message + & giveID mid + & buildRoute route (GetChannel (getID -> id)) = baseRoute id & buildRoute @@ -347,84 +352,131 @@ baseRoute id & buildRoute route (GetChannelMessages (getID -> id) _ _) = - baseRoute id // S "messages" - & buildRoute + baseRoute id + // S "messages" + & buildRoute route (GetMessage (getID -> cid) (getID @Message -> mid)) = - baseRoute cid // S "messages" // ID @Message - & giveID mid - & buildRoute + baseRoute cid + // S "messages" + // ID @Message + & giveID mid + & buildRoute route (CreateReaction (getID -> cid) (getID @Message -> mid) emoji) = - baseRoute cid // S "messages" // ID @Message // S "reactions" // PS @"emoji" // S "@me" - & giveID mid - & giveParam @"emoji" (renderEmoji emoji) - & buildRoute + baseRoute cid + // S "messages" + // ID @Message + // S "reactions" + // PS @"emoji" + // S "@me" + & giveID mid + & giveParam @"emoji" (renderEmoji emoji) + & buildRoute route (DeleteOwnReaction (getID -> cid) (getID @Message -> mid) emoji) = - baseRoute cid // S "messages" // ID @Message // S "reactions" // PS @"emoji" // S "@me" - & giveID mid - & giveParam @"emoji" (renderEmoji emoji) - & buildRoute + baseRoute cid + // S "messages" + // ID @Message + // S "reactions" + // PS @"emoji" + // S "@me" + & giveID mid + & giveParam @"emoji" (renderEmoji emoji) + & buildRoute route (DeleteUserReaction (getID -> cid) (getID @Message -> mid) emoji (getID @User -> uid)) = - baseRoute cid // S "messages" // ID @Message // S "reactions" // PS @"emoji" // ID @User - & giveID mid - & giveID uid - & giveParam @"emoji" (renderEmoji emoji) - & buildRoute + baseRoute cid + // S "messages" + // ID @Message + // S "reactions" + // PS @"emoji" + // ID @User + & giveID mid + & giveID uid + & giveParam @"emoji" (renderEmoji emoji) + & buildRoute route (GetReactions (getID -> cid) (getID @Message -> mid) emoji _) = - baseRoute cid // S "messages" // ID @Message // S "reactions" // PS @"emoji" - & giveID mid - & giveParam @"emoji" (renderEmoji emoji) - & buildRoute + baseRoute cid + // S "messages" + // ID @Message + // S "reactions" + // PS @"emoji" + & giveID mid + & giveParam @"emoji" (renderEmoji emoji) + & buildRoute route (DeleteAllReactions (getID -> cid) (getID @Message -> mid)) = - baseRoute cid // S "messages" // ID @Message // S "reactions" - & giveID mid - & buildRoute + baseRoute cid + // S "messages" + // ID @Message + // S "reactions" + & giveID mid + & buildRoute route (EditMessage (getID -> cid) (getID @Message -> mid) _) = - baseRoute cid // S "messages" // ID @Message - & giveID mid - & buildRoute + baseRoute cid + // S "messages" + // ID @Message + & giveID mid + & buildRoute route (DeleteMessage (getID -> cid) (getID @Message -> mid)) = - baseRoute cid // S "messages" // ID @Message - & giveID mid - & buildRoute + baseRoute cid + // S "messages" + // ID @Message + & giveID mid + & buildRoute route (BulkDeleteMessages (getID -> cid) _) = - baseRoute cid // S "messages" // S "bulk-delete" - & buildRoute + baseRoute cid + // S "messages" + // S "bulk-delete" + & buildRoute route (GetChannelInvites (getID -> cid)) = - baseRoute cid // S "invites" - & buildRoute + baseRoute cid + // S "invites" + & buildRoute route (CreateChannelInvite (getID -> cid) _) = - baseRoute cid // S "invites" - & buildRoute + baseRoute cid + // S "invites" + & buildRoute route (EditChannelPermissions (getID -> cid) (getID @Overwrite -> oid)) = - baseRoute cid // S "permissions" // ID @Overwrite - & giveID oid - & buildRoute + baseRoute cid + // S "permissions" + // ID @Overwrite + & giveID oid + & buildRoute route (DeleteChannelPermission (getID -> cid) (getID @Overwrite -> oid)) = - baseRoute cid // S "permissions" // ID @Overwrite - & giveID oid - & buildRoute + baseRoute cid + // S "permissions" + // ID @Overwrite + & giveID oid + & buildRoute route (TriggerTyping (getID -> cid)) = - baseRoute cid // S "typing" - & buildRoute + baseRoute cid + // S "typing" + & buildRoute route (GetPinnedMessages (getID -> cid)) = - baseRoute cid // S "pins" - & buildRoute + baseRoute cid + // S "pins" + & buildRoute route (AddPinnedMessage (getID -> cid) (getID @Message -> mid)) = - baseRoute cid // S "pins" // ID @Message - & giveID mid - & buildRoute + baseRoute cid + // S "pins" + // ID @Message + & giveID mid + & buildRoute route (DeletePinnedMessage (getID -> cid) (getID @Message -> mid)) = - baseRoute cid // S "pins" // ID @Message - & giveID mid - & buildRoute + baseRoute cid + // S "pins" + // ID @Message + & giveID mid + & buildRoute route (GroupDMAddRecipient (getID -> cid) (getID @User -> uid) _) = - baseRoute cid // S "recipients" // ID @User - & giveID uid - & buildRoute + baseRoute cid + // S "recipients" + // ID @User + & giveID uid + & buildRoute route (GroupDMRemoveRecipient (getID -> cid) (getID @User -> uid)) = - baseRoute cid // S "recipients" // ID @User - & giveID uid - & buildRoute + baseRoute cid + // S "recipients" + // ID @User + & giveID uid + & buildRoute action (CreateMessage _ cm) = \u o -> do let filePart CreateMessageAttachment {filename, content} n = (partFileRequestBody @IO (T.pack $ "files[" <> show n <> "]") "" content) diff --git a/Calamity/HTTP/Guild.hs b/Calamity/HTTP/Guild.hs --- a/Calamity/HTTP/Guild.hs +++ b/Calamity/HTTP/Guild.hs @@ -303,46 +303,49 @@ data GuildRequest a where CreateGuild :: CreateGuildData -> GuildRequest Guild - GetGuild :: HasID Guild g => g -> GuildRequest Guild - ModifyGuild :: HasID Guild g => g -> ModifyGuildData -> GuildRequest Guild - DeleteGuild :: HasID Guild g => g -> GuildRequest () - GetGuildChannels :: HasID Guild g => g -> GuildRequest [Channel] - CreateGuildChannel :: HasID Guild g => g -> ChannelCreateData -> GuildRequest Channel - ModifyGuildChannelPositions :: HasID Guild g => g -> [ChannelPosition] -> GuildRequest () + GetGuild :: (HasID Guild g) => g -> GuildRequest Guild + ModifyGuild :: (HasID Guild g) => g -> ModifyGuildData -> GuildRequest Guild + DeleteGuild :: (HasID Guild g) => g -> GuildRequest () + GetGuildChannels :: (HasID Guild g) => g -> GuildRequest [Channel] + CreateGuildChannel :: (HasID Guild g) => g -> ChannelCreateData -> GuildRequest Channel + ModifyGuildChannelPositions :: (HasID Guild g) => g -> [ChannelPosition] -> GuildRequest () GetGuildMember :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest Member - ListGuildMembers :: HasID Guild g => g -> ListMembersOptions -> GuildRequest [Member] - SearchGuildMembers :: HasID Guild g => g -> SearchMembersOptions -> GuildRequest [Member] + ListGuildMembers :: (HasID Guild g) => g -> ListMembersOptions -> GuildRequest [Member] + SearchGuildMembers :: (HasID Guild g) => g -> SearchMembersOptions -> GuildRequest [Member] AddGuildMember :: (HasID Guild g, HasID User u) => g -> u -> AddGuildMemberData -> GuildRequest (Maybe Member) ModifyGuildMember :: (HasID Guild g, HasID User u) => g -> u -> ModifyGuildMemberData -> GuildRequest () - ModifyCurrentUserNick :: HasID Guild g => g -> Maybe Text -> GuildRequest () + ModifyCurrentUserNick :: (HasID Guild g) => g -> Maybe Text -> GuildRequest () AddGuildMemberRole :: (HasID Guild g, HasID User u, HasID Role r) => g -> u -> r -> GuildRequest () RemoveGuildMemberRole :: (HasID Guild g, HasID User u, HasID Role r) => g -> u -> r -> GuildRequest () RemoveGuildMember :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest () - GetGuildBans :: HasID Guild g => g -> GetGuildBansOptions -> GuildRequest [BanData] + GetGuildBans :: (HasID Guild g) => g -> GetGuildBansOptions -> GuildRequest [BanData] GetGuildBan :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest BanData CreateGuildBan :: (HasID Guild g, HasID User u) => g -> u -> CreateGuildBanData -> GuildRequest () RemoveGuildBan :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest () - GetGuildRoles :: HasID Guild g => g -> GuildRequest [Role] - CreateGuildRole :: HasID Guild g => g -> ModifyGuildRoleData -> GuildRequest Role - ModifyGuildRolePositions :: HasID Guild g => g -> ModifyGuildRolePositionsData -> GuildRequest [Role] + GetGuildRoles :: (HasID Guild g) => g -> GuildRequest [Role] + CreateGuildRole :: (HasID Guild g) => g -> ModifyGuildRoleData -> GuildRequest Role + ModifyGuildRolePositions :: (HasID Guild g) => g -> ModifyGuildRolePositionsData -> GuildRequest [Role] ModifyGuildRole :: (HasID Guild g, HasID Role r) => g -> r -> ModifyGuildRoleData -> GuildRequest Role DeleteGuildRole :: (HasID Guild g, HasID Role r) => g -> r -> GuildRequest () - GetGuildPruneCount :: HasID Guild g => g -> Integer -> GuildRequest Integer - BeginGuildPrune :: HasID Guild g => g -> Integer -> Bool -> GuildRequest (Maybe Integer) - GetGuildVoiceRegions :: HasID Guild g => g -> GuildRequest [VoiceRegion] - GetGuildInvites :: HasID Guild g => g -> GuildRequest [Invite] + GetGuildPruneCount :: (HasID Guild g) => g -> Integer -> GuildRequest Integer + BeginGuildPrune :: (HasID Guild g) => g -> Integer -> Bool -> GuildRequest (Maybe Integer) + GetGuildVoiceRegions :: (HasID Guild g) => g -> GuildRequest [VoiceRegion] + GetGuildInvites :: (HasID Guild g) => g -> GuildRequest [Invite] baseRoute :: Snowflake Guild -> RouteBuilder _ baseRoute id = - mkRouteBuilder // S "guilds" // ID @Guild - & giveID id + mkRouteBuilder + // S "guilds" + // ID @Guild + & giveID id instance Request (GuildRequest a) where type Result (GuildRequest a) = a route (CreateGuild _) = - mkRouteBuilder // S "guilds" - & buildRoute + mkRouteBuilder + // S "guilds" + & buildRoute route (GetGuild (getID -> gid)) = baseRoute gid & buildRoute @@ -353,93 +356,136 @@ baseRoute gid & buildRoute route (GetGuildChannels (getID -> gid)) = - baseRoute gid // S "channels" - & buildRoute + baseRoute gid + // S "channels" + & buildRoute route (CreateGuildChannel (getID -> gid) _) = - baseRoute gid // S "channels" - & buildRoute + baseRoute gid + // S "channels" + & buildRoute route (ModifyGuildChannelPositions (getID -> gid) _) = - baseRoute gid // S "channels" - & buildRoute + baseRoute gid + // S "channels" + & buildRoute route (GetGuildMember (getID -> gid) (getID @User -> uid)) = - baseRoute gid // S "members" // ID @User - & giveID uid - & buildRoute + baseRoute gid + // S "members" + // ID @User + & giveID uid + & buildRoute route (ListGuildMembers (getID -> gid) _) = - baseRoute gid // S "members" - & buildRoute + baseRoute gid + // S "members" + & buildRoute route (SearchGuildMembers (getID -> gid) _) = - baseRoute gid // S "members" // S "search" - & buildRoute + baseRoute gid + // S "members" + // S "search" + & buildRoute route (AddGuildMember (getID -> gid) (getID @User -> uid) _) = - baseRoute gid // S "members" // ID @User - & giveID uid - & buildRoute + baseRoute gid + // S "members" + // ID @User + & giveID uid + & buildRoute route (ModifyGuildMember (getID -> gid) (getID @User -> uid) _) = - baseRoute gid // S "members" // ID @User - & giveID uid - & buildRoute + baseRoute gid + // S "members" + // ID @User + & giveID uid + & buildRoute route (ModifyCurrentUserNick (getID -> gid) _) = - baseRoute gid // S "members" // S "@me" // S "nick" - & buildRoute + baseRoute gid + // S "members" + // S "@me" + // S "nick" + & buildRoute route (AddGuildMemberRole (getID -> gid) (getID @User -> uid) (getID @Role -> rid)) = - baseRoute gid // S "members" // ID @User // S "roles" // ID @Role - & giveID uid - & giveID rid - & buildRoute + baseRoute gid + // S "members" + // ID @User + // S "roles" + // ID @Role + & giveID uid + & giveID rid + & buildRoute route (RemoveGuildMemberRole (getID -> gid) (getID @User -> uid) (getID @Role -> rid)) = - baseRoute gid // S "members" // ID @User // S "roles" // ID @Role - & giveID uid - & giveID rid - & buildRoute + baseRoute gid + // S "members" + // ID @User + // S "roles" + // ID @Role + & giveID uid + & giveID rid + & buildRoute route (RemoveGuildMember (getID -> gid) (getID @User -> uid)) = - baseRoute gid // S "members" // ID @User - & giveID uid - & buildRoute + baseRoute gid + // S "members" + // ID @User + & giveID uid + & buildRoute route (GetGuildBans (getID -> gid) _) = - baseRoute gid // S "bans" - & buildRoute + baseRoute gid + // S "bans" + & buildRoute route (GetGuildBan (getID -> gid) (getID @User -> uid)) = - baseRoute gid // S "bans" // ID @User - & giveID uid - & buildRoute + baseRoute gid + // S "bans" + // ID @User + & giveID uid + & buildRoute route (CreateGuildBan (getID -> gid) (getID @User -> uid) _) = - baseRoute gid // S "bans" // ID @User - & giveID uid - & buildRoute + baseRoute gid + // S "bans" + // ID @User + & giveID uid + & buildRoute route (RemoveGuildBan (getID -> gid) (getID @User -> uid)) = - baseRoute gid // S "bans" // ID @User - & giveID uid - & buildRoute + baseRoute gid + // S "bans" + // ID @User + & giveID uid + & buildRoute route (GetGuildRoles (getID -> gid)) = - baseRoute gid // S "roles" - & buildRoute + baseRoute gid + // S "roles" + & buildRoute route (CreateGuildRole (getID -> gid) _) = - baseRoute gid // S "roles" - & buildRoute + baseRoute gid + // S "roles" + & buildRoute route (ModifyGuildRolePositions (getID -> gid) _) = - baseRoute gid // S "roles" - & buildRoute + baseRoute gid + // S "roles" + & buildRoute route (ModifyGuildRole (getID -> gid) (getID @Role -> rid) _) = - baseRoute gid // S "roles" // ID @Role - & giveID rid - & buildRoute + baseRoute gid + // S "roles" + // ID @Role + & giveID rid + & buildRoute route (DeleteGuildRole (getID -> gid) (getID @Role -> rid)) = - baseRoute gid // S "roles" // ID @Role - & giveID rid - & buildRoute + baseRoute gid + // S "roles" + // ID @Role + & giveID rid + & buildRoute route (GetGuildPruneCount (getID -> gid) _) = - baseRoute gid // S "prune" - & buildRoute + baseRoute gid + // S "prune" + & buildRoute route (BeginGuildPrune (getID -> gid) _ _) = - baseRoute gid // S "prune" - & buildRoute + baseRoute gid + // S "prune" + & buildRoute route (GetGuildVoiceRegions (getID -> gid)) = - baseRoute gid // S "regions" - & buildRoute + baseRoute gid + // S "regions" + & buildRoute route (GetGuildInvites (getID -> gid)) = - baseRoute gid // S "invites" - & buildRoute + baseRoute gid + // S "invites" + & buildRoute action (CreateGuild o) = postWith' (ReqBodyJson o) action (GetGuild _) = getWith diff --git a/Calamity/HTTP/Interaction.hs b/Calamity/HTTP/Interaction.hs --- a/Calamity/HTTP/Interaction.hs +++ b/Calamity/HTTP/Interaction.hs @@ -259,8 +259,11 @@ baseRoute :: Snowflake Application -> InteractionToken -> RouteBuilder _ baseRoute id (InteractionToken token) = - mkRouteBuilder // S "webhooks" // ID @Application // S token - & giveID id + mkRouteBuilder + // S "webhooks" + // ID @Application + // S token + & giveID id foo :: Maybe a -> Maybe a -> (a -> a -> a) -> Maybe a foo (Just x) (Just y) f = Just (f x y) @@ -270,29 +273,53 @@ type Result (InteractionRequest a) = a route (CreateResponseDefer (getID @Interaction -> iid) (InteractionToken token) _) = - mkRouteBuilder // S "interactions" // ID @Interaction // S token // S "callback" - & giveID iid - & buildRoute + mkRouteBuilder + // S "interactions" + // ID @Interaction + // S token + // S "callback" + & giveID iid + & buildRoute route (CreateResponseDeferComponent (getID @Interaction -> iid) (InteractionToken token)) = - mkRouteBuilder // S "interactions" // ID @Interaction // S token // S "callback" - & giveID iid - & buildRoute + mkRouteBuilder + // S "interactions" + // ID @Interaction + // S token + // S "callback" + & giveID iid + & buildRoute route (CreateResponseMessage (getID @Interaction -> iid) (InteractionToken token) _) = - mkRouteBuilder // S "interactions" // ID @Interaction // S token // S "callback" - & giveID iid - & buildRoute + mkRouteBuilder + // S "interactions" + // ID @Interaction + // S token + // S "callback" + & giveID iid + & buildRoute route (CreateResponseUpdate (getID @Interaction -> iid) (InteractionToken token) _) = - mkRouteBuilder // S "interactions" // ID @Interaction // S token // S "callback" - & giveID iid - & buildRoute + mkRouteBuilder + // S "interactions" + // ID @Interaction + // S token + // S "callback" + & giveID iid + & buildRoute route (CreateResponseAutocomplete (getID @Interaction -> iid) (InteractionToken token) _) = - mkRouteBuilder // S "interactions" // ID @Interaction // S token // S "callback" - & giveID iid - & buildRoute + mkRouteBuilder + // S "interactions" + // ID @Interaction + // S token + // S "callback" + & giveID iid + & buildRoute route (CreateResponseModal (getID @Interaction -> iid) (InteractionToken token) _) = - mkRouteBuilder // S "interactions" // ID @Interaction // S token // S "callback" - & giveID iid - & buildRoute + mkRouteBuilder + // S "interactions" + // ID @Interaction + // S token + // S "callback" + & giveID iid + & buildRoute route (GetOriginalInteractionResponse (getID @Application -> aid) token) = baseRoute aid token // S "messages" // S "@original" & buildRoute route (EditOriginalInteractionResponse (getID @Application -> aid) token _) = diff --git a/Calamity/HTTP/Internal/Ratelimit.hs b/Calamity/HTTP/Internal/Ratelimit.hs --- a/Calamity/HTTP/Internal/Ratelimit.hs +++ b/Calamity/HTTP/Internal/Ratelimit.hs @@ -118,8 +118,11 @@ (bucket ^. #state) ( \bs -> bs - & #remaining .~ bs ^. #limit - & #resetTime .~ Nothing + & #remaining + .~ bs + ^. #limit + & #resetTime + .~ Nothing ) canResetBucketNow :: UTCTime -> BucketState -> Bool @@ -206,40 +209,40 @@ -- print "ok going forward with request" pure () -doDiscordRequest :: P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r => IO LbsResponse -> Sem r DiscordResponseType +doDiscordRequest :: (P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r) => IO LbsResponse -> Sem r DiscordResponseType doDiscordRequest r = do r'' <- P.embed $ Ex.catchAny (Right <$> r) (pure . Left . Ex.displayException) case r'' of Right r' -> do let status = responseStatus . toVanillaResponse $ r' if - | statusIsSuccessful status -> do - let resp = responseBody r' - debug $ "Got good response from discord: " <> (T.pack . show $ status) - now <- P.embed getCurrentTime - let rlHeaders = buildBucketState now r' - pure $ Good resp rlHeaders - | status == status429 -> do - now <- P.embed getCurrentTime - let resp = responseBody r' - case (resp ^? _Value, buildBucketState now r') of - (Just !rv, bs) -> - pure $ Ratelimited (parseRetryAfter now rv) (isGlobal rv) bs - _ -> - pure $ ServerError (statusCode status) - | statusIsClientError status -> do - let err = responseBody r' - error . T.pack $ "Something went wrong: " <> show err <> ", response: " <> show r' - pure $ ClientError (statusCode status) err - | otherwise -> do - debug . T.pack $ "Got server error from discord: " <> (show . statusCode $ status) - pure $ ServerError (statusCode status) + | statusIsSuccessful status -> do + let resp = responseBody r' + debug $ "Got good response from discord: " <> (T.pack . show $ status) + now <- P.embed getCurrentTime + let rlHeaders = buildBucketState now r' + pure $ Good resp rlHeaders + | status == status429 -> do + now <- P.embed getCurrentTime + let resp = responseBody r' + case (resp ^? _Value, buildBucketState now r') of + (Just !rv, bs) -> + pure $ Ratelimited (parseRetryAfter now rv) (isGlobal rv) bs + _ -> + pure $ ServerError (statusCode status) + | statusIsClientError status -> do + let err = responseBody r' + error . T.pack $ "Something went wrong: " <> show err <> ", response: " <> show r' + pure $ ClientError (statusCode status) err + | otherwise -> do + debug . T.pack $ "Got server error from discord: " <> (show . statusCode $ status) + pure $ ServerError (statusCode status) Left e -> do error . T.pack $ "Something went wrong with the http client: " <> e pure . InternalResponseError $ T.pack e -- | Parse a ratelimit header returning when it unlocks -parseRateLimitHeader :: HttpResponse r => UTCTime -> r -> Maybe UTCTime +parseRateLimitHeader :: (HttpResponse r) => UTCTime -> r -> Maybe UTCTime parseRateLimitHeader now r = computedEnd <|> end where computedEnd :: Maybe UTCTime @@ -253,10 +256,10 @@ posixSecondsToUTCTime . realToFrac <$> responseHeader r "X-Ratelimit-Reset" - ^? _Just - % _Double + ^? _Just + % _Double -buildBucketState :: HttpResponse r => UTCTime -> r -> Maybe (BucketState, B.ByteString) +buildBucketState :: (HttpResponse r) => UTCTime -> r -> Maybe (BucketState, B.ByteString) buildBucketState now r = (,) <$> bs <*> bucketKey where remaining = responseHeader r "X-RateLimit-Remaining" ^? _Just % _Integral @@ -282,7 +285,7 @@ | RGood b retryRequest :: - P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r => + (P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r) => -- | number of retries Int -> -- | action to perform @@ -319,7 +322,7 @@ -- Run a single request doSingleRequest :: - P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r => + (P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r) => RateLimitState -> Route -> -- | Global lock @@ -416,7 +419,7 @@ _ -> debug "unknown ratelimit" pure $ RFail (HTTPError c $ Aeson.decode v) -doRequest :: P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r => RateLimitState -> Route -> IO LbsResponse -> Sem r (Either RestError LB.ByteString) +doRequest :: (P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r) => RateLimitState -> Route -> IO LbsResponse -> Sem r (Either RestError LB.ByteString) doRequest rlstate route action = retryRequest 5 diff --git a/Calamity/HTTP/Internal/Request.hs b/Calamity/HTTP/Internal/Request.hs --- a/Calamity/HTTP/Internal/Request.hs +++ b/Calamity/HTTP/Internal/Request.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + -- | Generic Request type module Calamity.HTTP.Internal.Request ( Request (..), @@ -36,18 +38,18 @@ import Polysemy.Error qualified as P import Web.HttpApiData -throwIfLeft :: P.Member (P.Error RestError) r => Either String a -> P.Sem r a +throwIfLeft :: (P.Member (P.Error RestError) r) => Either String a -> P.Sem r a throwIfLeft (Right a) = pure a throwIfLeft (Left e) = P.throw (InternalClientError . T.pack $ e) -extractRight :: P.Member (P.Error e) r => Either e a -> P.Sem r a +extractRight :: (P.Member (P.Error e) r) => Either e a -> P.Sem r a extractRight (Left e) = P.throw e extractRight (Right a) = pure a class ReadResponse a where processResp :: LB.ByteString -> (Value -> Value) -> Either String a -instance {-# OVERLAPPABLE #-} FromJSON a => ReadResponse a where +instance {-# OVERLAPPABLE #-} (FromJSON a) => ReadResponse a where processResp s f = eitherDecode s >>= parseEither parseJSON . f instance ReadResponse () where @@ -109,19 +111,19 @@ getWith :: Url 'Https -> Option 'Https -> Req LbsResponse getWith u = req GET u NoReqBody lbsResponse -postWith' :: HttpBody a => a -> Url 'Https -> Option 'Https -> Req LbsResponse +postWith' :: (HttpBody a) => a -> Url 'Https -> Option 'Https -> Req LbsResponse postWith' a u = req POST u a lbsResponse -postWithP' :: HttpBody a => a -> Option 'Https -> Url 'Https -> Option 'Https -> Req LbsResponse +postWithP' :: (HttpBody a) => a -> Option 'Https -> Url 'Https -> Option 'Https -> Req LbsResponse postWithP' a o u o' = req POST u a lbsResponse (o <> o') postEmpty :: Url 'Https -> Option 'Https -> Req LbsResponse postEmpty u = req POST u NoReqBody lbsResponse -putWith' :: HttpBody a => a -> Url 'Https -> Option 'Https -> Req LbsResponse +putWith' :: (HttpBody a) => a -> Url 'Https -> Option 'Https -> Req LbsResponse putWith' a u = req PUT u a lbsResponse -patchWith' :: HttpBody a => a -> Url 'Https -> Option 'Https -> Req LbsResponse +patchWith' :: (HttpBody a) => a -> Url 'Https -> Option 'Https -> Req LbsResponse patchWith' a u = req PATCH u a lbsResponse putEmpty :: Url 'Https -> Option 'Https -> Req LbsResponse @@ -139,6 +141,6 @@ deleteWith :: Url 'Https -> Option 'Https -> Req LbsResponse deleteWith u = req DELETE u NoReqBody lbsResponse -(=:?) :: ToHttpApiData a => T.Text -> Maybe a -> Option 'Https +(=:?) :: (ToHttpApiData a) => T.Text -> Maybe a -> Option 'Https n =:? (Just x) = n =: x _ =:? Nothing = mempty diff --git a/Calamity/HTTP/Internal/Route.hs b/Calamity/HTTP/Internal/Route.hs --- a/Calamity/HTTP/Internal/Route.hs +++ b/Calamity/HTTP/Internal/Route.hs @@ -78,7 +78,7 @@ giveID :: forall t reqs. - Typeable t => + (Typeable t) => Snowflake t -> RouteBuilder reqs -> RouteBuilder ('( 'IDRequirement t, 'Satisfied) ': reqs) @@ -87,7 +87,7 @@ giveParam :: forall (s :: Symbol) reqs. - KnownSymbol s => + (KnownSymbol s) => Text -> RouteBuilder reqs -> RouteBuilder ('( 'PSRequirement s, 'Satisfied) ': reqs) @@ -126,7 +126,7 @@ AddRequiredInner ('Just 'NotNeeded) = 'Required AddRequiredInner 'Nothing = 'Required -class Typeable a => RouteFragmentable a reqs where +class (Typeable a) => RouteFragmentable a reqs where type ConsRes a reqs (//) :: RouteBuilder reqs -> a -> ConsRes a reqs @@ -137,13 +137,13 @@ (UnsafeMkRouteBuilder r ids params) // (S t) = UnsafeMkRouteBuilder (r <> [S' t]) ids params -instance Typeable a => RouteFragmentable (ID (a :: Type)) (reqs :: [(RequirementType, RouteRequirement)]) where +instance (Typeable a) => RouteFragmentable (ID (a :: Type)) (reqs :: [(RequirementType, RouteRequirement)]) where type ConsRes (ID a) reqs = RouteBuilder (AddRequired ('IDRequirement a) reqs) (UnsafeMkRouteBuilder r ids params) // ID = UnsafeMkRouteBuilder (r <> [ID' $ typeRep $ Proxy @a]) ids params -instance KnownSymbol s => RouteFragmentable (PS s) (reqs :: [(RequirementType, RouteRequirement)]) where +instance (KnownSymbol s) => RouteFragmentable (PS s) (reqs :: [(RequirementType, RouteRequirement)]) where type ConsRes (PS s) reqs = RouteBuilder (AddRequired ('PSRequirement s) reqs) (UnsafeMkRouteBuilder r ids params) // PS = @@ -169,7 +169,7 @@ buildRoute :: forall (reqs :: [(RequirementType, RouteRequirement)]). - EnsureFulfilled reqs => + (EnsureFulfilled reqs) => RouteBuilder reqs -> Route buildRoute (UnsafeMkRouteBuilder route ids params) = diff --git a/Calamity/HTTP/Internal/Types.hs b/Calamity/HTTP/Internal/Types.hs --- a/Calamity/HTTP/Internal/Types.hs +++ b/Calamity/HTTP/Internal/Types.hs @@ -61,14 +61,14 @@ = -- | A good response Good LB.ByteString + -- | The ratelimit headers if we got them (Maybe (BucketState, B.ByteString)) - -- ^ The ratelimit headers if we got them | -- | We hit a 429, no response and ratelimited Ratelimited + -- | Retry after UTCTime - -- ^ Retry after + -- | Global ratelimit Bool - -- ^ Global ratelimit (Maybe (BucketState, B.ByteString)) | -- | Discord's error, we should retry (HTTP 5XX) ServerError Int diff --git a/Calamity/HTTP/Reason.hs b/Calamity/HTTP/Reason.hs --- a/Calamity/HTTP/Reason.hs +++ b/Calamity/HTTP/Reason.hs @@ -13,10 +13,10 @@ deriving (Show, Eq) -- | Attach a reason to a request -reason :: Request a => Text -> a -> Reason a +reason :: (Request a) => Text -> a -> Reason a reason = flip Reason -instance Request a => Request (Reason a) where +instance (Request a) => Request (Reason a) where type Result (Reason a) = Result a route (Reason a _) = route a diff --git a/Calamity/HTTP/User.hs b/Calamity/HTTP/User.hs --- a/Calamity/HTTP/User.hs +++ b/Calamity/HTTP/User.hs @@ -51,11 +51,11 @@ data UserRequest a where GetCurrentUser :: UserRequest User - GetUser :: HasID User u => u -> UserRequest User + GetUser :: (HasID User u) => u -> UserRequest User ModifyCurrentUser :: ModifyUserData -> UserRequest User GetCurrentUserGuilds :: GetCurrentUserGuildsOptions -> UserRequest [Partial Guild] - LeaveGuild :: HasID Guild g => g -> UserRequest () - CreateDM :: HasID User u => u -> UserRequest DMChannel + LeaveGuild :: (HasID Guild g) => g -> UserRequest () + CreateDM :: (HasID User u) => u -> UserRequest DMChannel baseRoute :: RouteBuilder _ baseRoute = mkRouteBuilder // S "users" // S "@me" diff --git a/Calamity/HTTP/Webhook.hs b/Calamity/HTTP/Webhook.hs --- a/Calamity/HTTP/Webhook.hs +++ b/Calamity/HTTP/Webhook.hs @@ -121,16 +121,16 @@ $(makeFieldLabelsNoPrefix ''ExecuteWebhookOptions) data WebhookRequest a where - CreateWebhook :: HasID Channel c => c -> CreateWebhookData -> WebhookRequest Webhook - GetChannelWebhooks :: HasID Channel c => c -> WebhookRequest [Webhook] - GetGuildWebhooks :: HasID Guild c => c -> WebhookRequest [Webhook] - GetWebhook :: HasID Webhook w => w -> WebhookRequest Webhook - GetWebhookToken :: HasID Webhook w => w -> Text -> WebhookRequest Webhook - ModifyWebhook :: HasID Webhook w => w -> ModifyWebhookData -> WebhookRequest Webhook - ModifyWebhookToken :: HasID Webhook w => w -> Text -> ModifyWebhookData -> WebhookRequest Webhook - DeleteWebhook :: HasID Webhook w => w -> WebhookRequest () - DeleteWebhookToken :: HasID Webhook w => w -> Text -> WebhookRequest () - ExecuteWebhook :: HasID Webhook w => w -> Text -> ExecuteWebhookOptions -> WebhookRequest () + CreateWebhook :: (HasID Channel c) => c -> CreateWebhookData -> WebhookRequest Webhook + GetChannelWebhooks :: (HasID Channel c) => c -> WebhookRequest [Webhook] + GetGuildWebhooks :: (HasID Guild c) => c -> WebhookRequest [Webhook] + GetWebhook :: (HasID Webhook w) => w -> WebhookRequest Webhook + GetWebhookToken :: (HasID Webhook w) => w -> Text -> WebhookRequest Webhook + ModifyWebhook :: (HasID Webhook w) => w -> ModifyWebhookData -> WebhookRequest Webhook + ModifyWebhookToken :: (HasID Webhook w) => w -> Text -> ModifyWebhookData -> WebhookRequest Webhook + DeleteWebhook :: (HasID Webhook w) => w -> WebhookRequest () + DeleteWebhookToken :: (HasID Webhook w) => w -> Text -> WebhookRequest () + ExecuteWebhook :: (HasID Webhook w) => w -> Text -> ExecuteWebhookOptions -> WebhookRequest () baseRoute :: Snowflake Webhook -> RouteBuilder _ baseRoute id = mkRouteBuilder // S "webhooks" // ID @Webhook & giveID id @@ -139,38 +139,51 @@ type Result (WebhookRequest a) = a route (CreateWebhook (getID @Channel -> cid) _) = - mkRouteBuilder // S "channels" // ID @Channel // S "webhooks" - & giveID cid - & buildRoute + mkRouteBuilder + // S "channels" + // ID @Channel + // S "webhooks" + & giveID cid + & buildRoute route (GetChannelWebhooks (getID @Channel -> cid)) = - mkRouteBuilder // S "channels" // ID @Channel // S "webhooks" - & giveID cid - & buildRoute + mkRouteBuilder + // S "channels" + // ID @Channel + // S "webhooks" + & giveID cid + & buildRoute route (GetGuildWebhooks (getID @Guild -> gid)) = - mkRouteBuilder // S "guilds" // ID @Guild // S "webhooks" - & giveID gid - & buildRoute + mkRouteBuilder + // S "guilds" + // ID @Guild + // S "webhooks" + & giveID gid + & buildRoute route (GetWebhook (getID @Webhook -> wid)) = baseRoute wid & buildRoute route (GetWebhookToken (getID @Webhook -> wid) t) = - baseRoute wid // S t - & buildRoute + baseRoute wid + // S t + & buildRoute route (ModifyWebhook (getID @Webhook -> wid) _) = baseRoute wid & buildRoute route (ModifyWebhookToken (getID @Webhook -> wid) t _) = - baseRoute wid // S t - & buildRoute + baseRoute wid + // S t + & buildRoute route (DeleteWebhook (getID @Webhook -> wid)) = baseRoute wid & buildRoute route (DeleteWebhookToken (getID @Webhook -> wid) t) = - baseRoute wid // S t - & buildRoute + baseRoute wid + // S t + & buildRoute route (ExecuteWebhook (getID @Webhook -> wid) t _) = - baseRoute wid // S t - & buildRoute + baseRoute wid + // S t + & buildRoute action (CreateWebhook _ o) = postWith' $ ReqBodyJson o action (GetChannelWebhooks _) = getWith diff --git a/Calamity/Interactions/Eff.hs b/Calamity/Interactions/Eff.hs --- a/Calamity/Interactions/Eff.hs +++ b/Calamity/Interactions/Eff.hs @@ -24,16 +24,16 @@ makeSem ''InteractionEff -getInteractionID :: P.Member InteractionEff r => P.Sem r (Snowflake Interaction) +getInteractionID :: (P.Member InteractionEff r) => P.Sem r (Snowflake Interaction) getInteractionID = (^. #id) <$> getInteraction -getApplicationID :: P.Member InteractionEff r => P.Sem r (Snowflake Application) +getApplicationID :: (P.Member InteractionEff r) => P.Sem r (Snowflake Application) getApplicationID = (^. #applicationID) <$> getInteraction -getInteractionToken :: P.Member InteractionEff r => P.Sem r InteractionToken +getInteractionToken :: (P.Member InteractionEff r) => P.Sem r InteractionToken getInteractionToken = (^. #token) <$> getInteraction -getInteractionUser :: P.Member InteractionEff r => P.Sem r (Snowflake User) +getInteractionUser :: (P.Member InteractionEff r) => P.Sem r (Snowflake User) getInteractionUser = do int <- getInteraction let uid = int ^? #user % _Just % #id diff --git a/Calamity/Interactions/Utils.hs b/Calamity/Interactions/Utils.hs --- a/Calamity/Interactions/Utils.hs +++ b/Calamity/Interactions/Utils.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + -- | Interaction related utilities module Calamity.Interactions.Utils ( respond, @@ -32,7 +34,7 @@ -} userLocalState :: forall r s a. - P.Member InteractionEff r => + (P.Member InteractionEff r) => -- | Initial state s -> P.Sem (P.State s ': r) a -> @@ -165,7 +167,7 @@ invoke $ CreateFollowupMessage applicationID interactionToken opts -- | Defer an interaction and show a loading state, use @followUp@ later on -defer :: P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r => P.Sem r (Either RestError ()) +defer :: (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r) => P.Sem r (Either RestError ()) defer = do interactionID <- getInteractionID interactionToken <- getInteractionToken @@ -174,14 +176,14 @@ {- | Defer an interaction and show an ephemeral loading state, use @followUp@ later on -} -deferEphemeral :: P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r => P.Sem r (Either RestError ()) +deferEphemeral :: (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r) => P.Sem r (Either RestError ()) deferEphemeral = do interactionID <- getInteractionID interactionToken <- getInteractionToken invoke $ CreateResponseDefer interactionID interactionToken True -- | Defer operation -deferComponent :: P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r => P.Sem r (Either RestError ()) +deferComponent :: (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r) => P.Sem r (Either RestError ()) deferComponent = do interactionID <- getInteractionID interactionToken <- getInteractionToken @@ -195,7 +197,7 @@ You should probably use this with 'Calamity.Interaction.View.runView' -} -pushModal :: P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r => Text -> [Component] -> P.Sem r (Either RestError ()) +pushModal :: (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r) => Text -> [Component] -> P.Sem r (Either RestError ()) pushModal title c = do -- we don't actually use the custom id of the modal. the custom ids of the -- sub-components are enough to disambiguate diff --git a/Calamity/Interactions/View.hs b/Calamity/Interactions/View.hs --- a/Calamity/Interactions/View.hs +++ b/Calamity/Interactions/View.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} module Calamity.Interactions.View ( ViewEff (..), @@ -62,7 +63,7 @@ -} data View a = NilView a - | SingView (forall g. RandomGen g => g -> (ViewComponent a, g)) + | SingView (forall g. (RandomGen g) => g -> (ViewComponent a, g)) | RowView (View a) | forall x. MultView (View (x -> a)) (View x) @@ -92,7 +93,7 @@ 'E.:$$: 'E.Text "Also, make sure you use lazy patterns: ~(a, b) instead of (a, b)" 'E.:$$: 'E.Text "Refer to https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/applicative_do.html" -instance E.TypeError MonadViewMessage => Monad View where +instance (E.TypeError MonadViewMessage) => Monad View where (>>=) = undefined -- unreachable data ExtractOkType @@ -296,7 +297,7 @@ -- componentIDS (C.TextInput' C.TextInput {customID}) = S.singleton customID -- | Generate a 'ViewInstance' of a 'View' by filling in 'CustomID's with random values -instantiateView :: RandomGen g => g -> View a -> (ViewInstance a, g) +instantiateView :: (RandomGen g) => g -> View a -> (ViewInstance a, g) instantiateView g v = case v of NilView x -> (ViewInstance (const $ ExtractOk SomeExtracted x) [], g) @@ -332,7 +333,7 @@ views after a timeout. -} runView :: - BotC r => + (BotC r) => -- | The initial view to render View inp -> -- | A function to send the rendered view (i.e. as a message or a modal) @@ -352,7 +353,7 @@ This function won't send the view, you should do that yourself -} runViewInstance :: - BotC r => + (BotC r) => -- | An initial value to act as the value of @GetSendResponse@ -- -- If you just sent a message, probably pass that @@ -389,7 +390,7 @@ interpretView :: forall r ret inp sendResp. - P.Member (P.Embed IO) r => + (P.Member (P.Embed IO) r) => P.Sem (ViewEff ret inp sendResp ': r) () -> P.Sem (P.State (Maybe ret, ViewInstance inp, sendResp) ': r) () interpretView = @@ -405,7 +406,7 @@ innerLoop :: forall r ret inp sendResp. - P.Members '[RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r => + (P.Members '[RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r) => sendResp -> ViewInstance inp -> STM.TQueue Interaction -> diff --git a/Calamity/Internal/BoundedStore.hs b/Calamity/Internal/BoundedStore.hs --- a/Calamity/Internal/BoundedStore.hs +++ b/Calamity/Internal/BoundedStore.hs @@ -12,7 +12,8 @@ import Calamity.Internal.Utils (unlessM, whenM) import Calamity.Types.Snowflake (HasID (getID), HasID', Snowflake) -import Control.Monad.State.Lazy (execState, when) +import Control.Monad (when) +import Control.Monad.State.Lazy (execState) import Data.Default.Class (Default (..)) import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as H @@ -44,9 +45,9 @@ type instance IxValue (BoundedStore a) = a -instance HasID' a => Ixed (BoundedStore a) +instance (HasID' a) => Ixed (BoundedStore a) -instance HasID' a => At (BoundedStore a) where +instance (HasID' a) => At (BoundedStore a) where at k = lensVL $ \f m -> let mv = getItem k m in f mv <&> \case @@ -54,7 +55,7 @@ Just v -> addItem v m {-# INLINE at #-} -addItem :: HasID' a => a -> BoundedStore a -> BoundedStore a +addItem :: (HasID' a) => a -> BoundedStore a -> BoundedStore a addItem m = execState $ do unlessM (H.member (getID m) <$> use #items) $ do #itemQueue %= DQ.cons (getID m) diff --git a/Calamity/Internal/ConstructorName.hs b/Calamity/Internal/ConstructorName.hs --- a/Calamity/Internal/ConstructorName.hs +++ b/Calamity/Internal/ConstructorName.hs @@ -9,10 +9,10 @@ class GCtorName f where gctorName :: f a -> String -instance Constructor c => GCtorName (C1 c f) where +instance (Constructor c) => GCtorName (C1 c f) where gctorName = conName -instance GCtorName f => GCtorName (D1 d f) where +instance (GCtorName f) => GCtorName (D1 d f) where gctorName (M1 a) = gctorName a instance (GCtorName f, GCtorName g) => GCtorName (f :+: g) where diff --git a/Calamity/Internal/LocalWriter.hs b/Calamity/Internal/LocalWriter.hs --- a/Calamity/Internal/LocalWriter.hs +++ b/Calamity/Internal/LocalWriter.hs @@ -17,7 +17,7 @@ P.makeSem ''LocalWriter -runLocalWriter :: Monoid o => P.Sem (LocalWriter o ': r) a -> P.Sem r (o, a) +runLocalWriter :: (Monoid o) => P.Sem (LocalWriter o ': r) a -> P.Sem r (o, a) runLocalWriter = P.runState mempty . P.reinterpretH diff --git a/Calamity/Internal/RunIntoIO.hs b/Calamity/Internal/RunIntoIO.hs --- a/Calamity/Internal/RunIntoIO.hs +++ b/Calamity/Internal/RunIntoIO.hs @@ -9,13 +9,13 @@ import Polysemy qualified as P import Polysemy.Final qualified as P -runSemToIO :: forall r a. P.Member (P.Final IO) r => P.Sem r a -> P.Sem r (IO (Maybe a)) +runSemToIO :: forall r a. (P.Member (P.Final IO) r) => P.Sem r a -> P.Sem r (IO (Maybe a)) runSemToIO m = P.withStrategicToFinal $ do m' <- P.runS m ins <- P.getInspectorS P.liftS $ pure (P.inspect ins <$> m') -bindSemToIO :: forall r p a. P.Member (P.Final IO) r => (p -> P.Sem r a) -> P.Sem r (p -> IO (Maybe a)) +bindSemToIO :: forall r p a. (P.Member (P.Final IO) r) => (p -> P.Sem r a) -> P.Sem r (p -> IO (Maybe a)) bindSemToIO m = P.withStrategicToFinal $ do istate <- P.getInitialStateS m' <- P.bindS m diff --git a/Calamity/Internal/SnowflakeMap.hs b/Calamity/Internal/SnowflakeMap.hs --- a/Calamity/Internal/SnowflakeMap.hs +++ b/Calamity/Internal/SnowflakeMap.hs @@ -68,7 +68,7 @@ empty = SnowflakeMap SH.empty {-# INLINEABLE empty #-} -singleton :: HasID' a => a -> SnowflakeMap a +singleton :: (HasID' a) => a -> SnowflakeMap a singleton v = SnowflakeMap $ SH.singleton (getID v) v {-# INLINEABLE singleton #-} @@ -98,11 +98,11 @@ infixl 9 ! -insert :: HasID' a => a -> SnowflakeMap a -> SnowflakeMap a +insert :: (HasID' a) => a -> SnowflakeMap a -> SnowflakeMap a insert v = overSM $ SH.insert (getID v) v {-# INLINEABLE insert #-} -insertWith :: HasID' a => (a -> a -> a) -> a -> SnowflakeMap a -> SnowflakeMap a +insertWith :: (HasID' a) => (a -> a -> a) -> a -> SnowflakeMap a -> SnowflakeMap a insertWith f v = overSM $ SH.insertWith f (getID v) v {-# INLINEABLE insertWith #-} @@ -146,7 +146,7 @@ mapWithKey f = overSM $ coerceSnowflakeMap . SH.mapWithKey f {-# INLINEABLE mapWithKey #-} -traverseWithKey :: Applicative f => (Snowflake a1 -> a1 -> f a2) -> SnowflakeMap a1 -> f (SnowflakeMap a2) +traverseWithKey :: (Applicative f) => (Snowflake a1 -> a1 -> f a2) -> SnowflakeMap a1 -> f (SnowflakeMap a2) traverseWithKey f = fmap (SnowflakeMap . coerceSnowflakeMap) . SH.traverseWithKey f . unSnowflakeMap {-# INLINEABLE traverseWithKey #-} @@ -214,11 +214,11 @@ toList = SH.toList . unSnowflakeMap {-# INLINEABLE toList #-} -fromList :: HasID' a => [a] -> SnowflakeMap a +fromList :: (HasID' a) => [a] -> SnowflakeMap a fromList = SnowflakeMap . SH.fromList . Prelude.map (\v -> (getID v, v)) {-# INLINEABLE fromList #-} -fromListWith :: HasID' a => (a -> a -> a) -> [a] -> SnowflakeMap a +fromListWith :: (HasID' a) => (a -> a -> a) -> [a] -> SnowflakeMap a fromListWith f = SnowflakeMap . SH.fromListWith f . Prelude.map (\v -> (getID v, v)) {-# INLINEABLE fromListWith #-} @@ -227,6 +227,6 @@ parsed <- traverse parseJSON l pure . Calamity.Internal.SnowflakeMap.fromList . F.toList $ parsed -instance ToJSON a => ToJSON (SnowflakeMap a) where +instance (ToJSON a) => ToJSON (SnowflakeMap a) where toJSON = toJSON . elems toEncoding = toEncoding . elems diff --git a/Calamity/Internal/Utils.hs b/Calamity/Internal/Utils.hs --- a/Calamity/Internal/Utils.hs +++ b/Calamity/Internal/Utils.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + -- | Internal utilities and instances module Calamity.Internal.Utils ( whileMFinalIO, @@ -46,7 +49,7 @@ This means Polysemy.Error won't work to break the loop, etc. Instead, Error/Alternative will just result in the loop quitting. -} -whileMFinalIO :: P.Member (P.Final IO) r => P.Sem r Bool -> P.Sem r () +whileMFinalIO :: (P.Member (P.Final IO) r) => P.Sem r Bool -> P.Sem r () whileMFinalIO action = do action' <- runSemToIO action P.embedFinal $ go action' @@ -64,7 +67,7 @@ This means Polysemy.Error won't work to break the loop, etc. Instead, Error/Alternative will just result in another loop. -} -untilJustFinalIO :: P.Member (P.Final IO) r => P.Sem r (Maybe a) -> P.Sem r a +untilJustFinalIO :: (P.Member (P.Final IO) r) => P.Sem r (Maybe a) -> P.Sem r a untilJustFinalIO action = do action' <- runSemToIO action P.embedFinal $ go action' @@ -77,16 +80,16 @@ _ -> go action' -whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () +whenJust :: (Applicative m) => Maybe a -> (a -> m ()) -> m () whenJust = flip $ maybe (pure ()) -whenM :: Monad m => m Bool -> m () -> m () +whenM :: (Monad m) => m Bool -> m () -> m () whenM p m = p >>= \case True -> m False -> pure () -unlessM :: Monad m => m Bool -> m () -> m () +unlessM :: (Monad m) => m Bool -> m () -> m () unlessM = whenM . (not <$>) lastMaybe :: Maybe a -> Maybe a -> Maybe a @@ -114,18 +117,18 @@ infixl 4 <<*>> -(<.>) :: Functor f => (a -> b) -> (c -> f a) -> (c -> f b) +(<.>) :: (Functor f) => (a -> b) -> (c -> f a) -> (c -> f b) (<.>) f g x = f <$> g x infixl 4 <.> -debug :: P.Member LogEff r => Text -> P.Sem r () +debug :: (P.Member LogEff r) => Text -> P.Sem r () debug = Di.debug -info :: P.Member LogEff r => Text -> P.Sem r () +info :: (P.Member LogEff r) => Text -> P.Sem r () info = Di.info -error :: P.Member LogEff r => Text -> P.Sem r () +error :: (P.Member LogEff r) => Text -> P.Sem r () error = Di.error swap :: (a, b) -> (b, a) @@ -161,17 +164,28 @@ | NotNull a deriving (Show) -instance Aeson.FromJSON a => Aeson.FromJSON (MaybeNull a) where +instance (Aeson.FromJSON a) => Aeson.FromJSON (MaybeNull a) where parseJSON Aeson.Null = pure WasNull parseJSON x = NotNull <$> Aeson.parseJSON x -instance Aeson.ToJSON a => Aeson.ToJSON (MaybeNull a) where +instance (Aeson.ToJSON a) => Aeson.ToJSON (MaybeNull a) where toJSON WasNull = Aeson.Null toJSON (NotNull x) = Aeson.toJSON x toEncoding WasNull = null_ toEncoding (NotNull x) = Aeson.toEncoding x +#if MIN_VERSION_aeson(2,2,0) +(.?=) :: (Aeson.ToJSON v, Aeson.KeyValue e kv) => Aeson.Key -> Maybe v -> Maybe kv +k .?= Just v = Just (k Aeson..= v) +_ .?= Nothing = Nothing + +(.=) :: (Aeson.ToJSON v, Aeson.KeyValue e kv) => Aeson.Key -> v -> Maybe kv +k .= v = Just (k Aeson..= v) + +class CalamityToJSON' a where + toPairs :: Aeson.KeyValue kv => a -> [Maybe kv] +#else (.?=) :: (Aeson.ToJSON v, Aeson.KeyValue kv) => Aeson.Key -> Maybe v -> Maybe kv k .?= Just v = Just (k Aeson..= v) _ .?= Nothing = Nothing @@ -181,9 +195,10 @@ class CalamityToJSON' a where toPairs :: Aeson.KeyValue kv => a -> [Maybe kv] +#endif newtype CalamityToJSON a = CalamityToJSON a -instance CalamityToJSON' a => Aeson.ToJSON (CalamityToJSON a) where +instance (CalamityToJSON' a) => Aeson.ToJSON (CalamityToJSON a) where toJSON (CalamityToJSON x) = Aeson.object . catMaybes . toPairs $ x toEncoding (CalamityToJSON x) = Aeson.pairs . mconcat . catMaybes . toPairs $ x diff --git a/Calamity/Types/CDNAsset.hs b/Calamity/Types/CDNAsset.hs --- a/Calamity/Types/CDNAsset.hs +++ b/Calamity/Types/CDNAsset.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + -- | Things that can be fetched from the discord CDN module Calamity.Types.CDNAsset ( CDNAsset (..), diff --git a/Calamity/Types/Model/Channel/Attachment.hs b/Calamity/Types/Model/Channel/Attachment.hs --- a/Calamity/Types/Model/Channel/Attachment.hs +++ b/Calamity/Types/Model/Channel/Attachment.hs @@ -13,7 +13,7 @@ import Optics.TH import TextShow.TH -fuseTup2 :: Monad f => (f a, f b) -> f (a, b) +fuseTup2 :: (Monad f) => (f a, f b) -> f (a, b) fuseTup2 (a, b) = do !a' <- a !b' <- b diff --git a/Calamity/Types/Model/Channel/Embed.hs b/Calamity/Types/Model/Channel/Embed.hs --- a/Calamity/Types/Model/Channel/Embed.hs +++ b/Calamity/Types/Model/Channel/Embed.hs @@ -346,26 +346,64 @@ instance Semigroup EmbedFooter where l <> r = l - & #text %~ (<> (r ^. #text)) - & #iconUrl %~ getLast . (<> Last (r ^. #iconUrl)) . Last - & #proxyIconUrl %~ getLast . (<> Last (r ^. #proxyIconUrl)) . Last + & #text + %~ (<> (r ^. #text)) + & #iconUrl + %~ getLast + . (<> Last (r ^. #iconUrl)) + . Last + & #proxyIconUrl + %~ getLast + . (<> Last (r ^. #proxyIconUrl)) + . Last instance Semigroup Embed where l <> r = l - & #title %~ (<> (r ^. #title)) - & #type_ %~ getLast . (<> Last (r ^. #type_)) . Last - & #description %~ (<> (r ^. #description)) - & #url %~ getLast . (<> Last (r ^. #url)) . Last - & #timestamp %~ getLast . (<> Last (r ^. #timestamp)) . Last - & #color %~ getLast . (<> Last (r ^. #color)) . Last - & #footer %~ (<> (r ^. #footer)) - & #image %~ getLast . (<> Last (r ^. #image)) . Last - & #thumbnail %~ getLast . (<> Last (r ^. #thumbnail)) . Last - & #video %~ getLast . (<> Last (r ^. #video)) . Last - & #provider %~ getLast . (<> Last (r ^. #provider)) . Last - & #author %~ getLast . (<> Last (r ^. #author)) . Last - & #fields %~ (<> (r ^. #fields)) + & #title + %~ (<> (r ^. #title)) + & #type_ + %~ getLast + . (<> Last (r ^. #type_)) + . Last + & #description + %~ (<> (r ^. #description)) + & #url + %~ getLast + . (<> Last (r ^. #url)) + . Last + & #timestamp + %~ getLast + . (<> Last (r ^. #timestamp)) + . Last + & #color + %~ getLast + . (<> Last (r ^. #color)) + . Last + & #footer + %~ (<> (r ^. #footer)) + & #image + %~ getLast + . (<> Last (r ^. #image)) + . Last + & #thumbnail + %~ getLast + . (<> Last (r ^. #thumbnail)) + . Last + & #video + %~ getLast + . (<> Last (r ^. #video)) + . Last + & #provider + %~ getLast + . (<> Last (r ^. #provider)) + . Last + & #author + %~ getLast + . (<> Last (r ^. #author)) + . Last + & #fields + %~ (<> (r ^. #fields)) instance Monoid Embed where mempty = def diff --git a/Calamity/Types/Tellable.hs b/Calamity/Types/Tellable.hs --- a/Calamity/Types/Tellable.hs +++ b/Calamity/Types/Tellable.hs @@ -141,7 +141,7 @@ class Tellable a where getChannel :: (BotC r, P.Member (P.Error RestError) r) => a -> P.Sem r (Snowflake Channel) -runToMessage :: ToMessage a => a -> CreateMessageOptions +runToMessage :: (ToMessage a) => a -> CreateMessageOptions runToMessage = flip appEndo def . intoMsg {- | Send a message to something that is messageable diff --git a/Calamity/Types/Upgradeable.hs b/Calamity/Types/Upgradeable.hs --- a/Calamity/Types/Upgradeable.hs +++ b/Calamity/Types/Upgradeable.hs @@ -24,9 +24,9 @@ -- -- If it existed in the cache then it is returned from there, otherwise we -- fetch from HTTP and update the cache on success. - upgrade :: BotC r => ids -> P.Sem r (Maybe a) + upgrade :: (BotC r) => ids -> P.Sem r (Maybe a) -maybeToAlt :: Alternative f => Maybe a -> f a +maybeToAlt :: (Alternative f) => Maybe a -> f a maybeToAlt (Just x) = pure x maybeToAlt Nothing = empty @@ -58,7 +58,7 @@ Right g <- invoke $ H.GetGuild gid pure g -insertChannel :: BotC r => Channel -> P.Sem r () +insertChannel :: (BotC r) => Channel -> P.Sem r () insertChannel (DMChannel' dm) = setDM dm insertChannel (GuildChannel' ch) = updateGuild (getID ch) (#channels % at (getID @GuildChannel ch) ?~ ch) diff --git a/Calamity/Utils/Message.hs b/Calamity/Utils/Message.hs --- a/Calamity/Utils/Message.hs +++ b/Calamity/Utils/Message.hs @@ -44,7 +44,7 @@ import Optics import TextShow (TextShow (showt)) -zws :: IsString s => s +zws :: (IsString s) => s zws = fromString "\x200b" -- | Replaces all occurences of @\`\`\`@ with @\`\\`\\`@ diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for Calamity +## 0.11.0.0 + ++ Added support for Aeson 2.2 @Miezhiko ++ Support MTL 2.3+ @Miezhiko + ## 0.10.0.0 + Updated `CreateMessageAttachment.content` to be a `Network.HTTP.Client.RequestBody` diff --git a/calamity.cabal b/calamity.cabal --- a/calamity.cabal +++ b/calamity.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: calamity -version: 0.10.0.0 +version: 0.11.0.0 synopsis: A library for writing discord bots in haskell description: Please see the README on GitHub at @@ -14,7 +14,7 @@ license: MIT license-file: LICENSE build-type: Simple -tested-with: GHC ==9.4.4 +tested-with: GHC ==9.6.4 extra-source-files: ChangeLog.md README.md @@ -130,7 +130,6 @@ hs-source-dirs: ./ default-extensions: - NoMonomorphismRestriction AllowAmbiguousTypes BangPatterns BinaryLiterals @@ -162,6 +161,7 @@ MultiParamTypeClasses MultiWayIf NamedFieldPuns + NoMonomorphismRestriction OverloadedLabels OverloadedStrings PartialTypeSignatures @@ -182,20 +182,17 @@ UndecidableInstances ViewPatterns - ghc-options: - -fplugin=Polysemy.Plugin -funbox-strict-fields -Wall - -fno-warn-name-shadowing - + ghc-options: -funbox-strict-fields -Wall -fno-warn-name-shadowing build-depends: - aeson >=2.0 && <2.2 + aeson >=2.1 && <2.3 , aeson-optics >=1.2 && <2 , async >=2.2 && <3 , base >=4.13 && <5 - , bytestring >=0.10 && <0.12 + , bytestring >=0.10 && <0.13 , calamity-commands >=0.4 && <0.5 , colour >=2.3.5 && <2.4 , concurrent-extra >=0.7 && <0.8 - , containers >=0.6 && <0.7 + , containers >=0.6 && <0.8 , crypton-connection >=0.2.6 && <0.4 , crypton-x509-system >=1.6.6 && <1.7 , data-default-class >=0.1 && <0.2 @@ -208,7 +205,7 @@ , exceptions >=0.10 && <0.11 , focus >=1.0 && <2 , hashable >=1.2 && <2 - , http-api-data >=0.4.3 && <0.6 + , http-api-data >=0.4.3 && <0.7 , http-client >=0.5 && <0.8 , http-date >=0.0.8 && <0.1 , http-types >=0.12 && <0.13 @@ -226,15 +223,15 @@ , stm >=2.5 && <3 , stm-chans >=3.0 && <4 , stm-containers >=1.1 && <2 - , text >=1.2 && <2.1 + , text >=1.2 && <2.2 , text-show >=3.8 && <4 - , time >=1.8 && <1.13 - , tls >=1.7 && <2 + , time >=1.8 && <1.15 + , tls >=1.7 && <3 , typerep-map >=0.5 && <0.7 , unagi-chan >=0.4 && <0.5 , unboxing-vector >=0.2 && <0.3 , unordered-containers >=0.2 && <0.3 , vector >=0.12 && <0.14 - , websockets >=0.12 && <0.13 + , websockets >=0.13 && <0.14 default-language: Haskell2010