calamity 0.1.30.1 → 0.1.30.2

raw patch · 31 files changed

+743/−489 lines, 31 filesdep +PyFdep −fmtPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: PyF

Dependencies removed: fmt

API changes (from Hackage documentation)

Files

• Calamity/Client/Client.hs +64/−68
• Calamity/Client/ShardManager.hs +16/−22
• Calamity/Client/Types.hs +1/−2
• Calamity/Commands.hs +2/−2
• Calamity/Gateway/DispatchEvents.hs +7/−10
• Calamity/Gateway/Shard.hs +10/−10
• Calamity/HTTP/Guild.hs +2/−3
• Calamity/HTTP/Internal/Ratelimit.hs +13/−20
• Calamity/Internal/IntColour.hs +32/−23
• Calamity/Internal/OverriddenVia.hs +36/−0
• Calamity/Internal/ShapeCoerce.hs +37/−0
• Calamity/Internal/SnowflakeMap.hs +2/−3
• Calamity/Internal/UnixTimestamp.hs +64/−0
• Calamity/Internal/Utils.hs +80/−85
• Calamity/Metrics/Eff.hs +56/−43
• Calamity/Types.hs +0/−2
• Calamity/Types/Model/Channel/DM.hs +18/−11
• Calamity/Types/Model/Channel/Embed.hs +24/−9
• Calamity/Types/Model/Channel/Group.hs +36/−26
• Calamity/Types/Model/Channel/Guild/Text.hs +20/−2
• Calamity/Types/Model/Channel/Message.hs +44/−15
• Calamity/Types/Model/Channel/UpdatedMessage.hs +28/−9
• Calamity/Types/Model/Guild/Emoji.hs +22/−12
• Calamity/Types/Model/Guild/Guild.hs +50/−8
• Calamity/Types/Model/Guild/Member.hs +29/−7
• Calamity/Types/Model/Guild/Role.hs +17/−4
• Calamity/Types/Model/Presence/Activity.hs +13/−16
• Calamity/Types/UnixTimestamp.hs +0/−68
• ChangeLog.md +9/−1
• README.md +3/−1
• calamity.cabal +8/−7

@@ -1,73 +1,69 @@ {-# OPTIONS_GHC -Wno-name-shadowing #-}  -- | The client-module Calamity.Client.Client-    ( react-    , runBotIO-    , runBotIO'-    , stopBot-    , sendPresence-    , events-    , fire-    , waitUntil-    , waitUntilM-    , CalamityEvent(Dispatch, ShutDown)-    , customEvt ) where+module Calamity.Client.Client (+  react,+  runBotIO,+  runBotIO',+  stopBot,+  sendPresence,+  events,+  fire,+  waitUntil,+  waitUntilM,+  CalamityEvent (Dispatch, ShutDown),+  customEvt,+) where -import           Calamity.Cache.Eff-import           Calamity.Client.ShardManager-import           Calamity.Client.Types-import           Calamity.Gateway.DispatchEvents-import           Calamity.Gateway.Types-import           Calamity.Gateway.Intents-import           Calamity.HTTP.Internal.Ratelimit-import           Calamity.Internal.ConstructorName-import           Calamity.Internal.RunIntoIO-import qualified Calamity.Internal.SnowflakeMap    as SM-import           Calamity.Internal.Updateable-import           Calamity.Internal.Utils-import           Calamity.Metrics.Eff-import           Calamity.Types.Model.Channel-import           Calamity.Types.Model.Guild-import           Calamity.Types.Model.Presence     ( Presence(..) )-import           Calamity.Types.Model.User+import Calamity.Cache.Eff+import Calamity.Client.ShardManager+import Calamity.Client.Types+import Calamity.Gateway.DispatchEvents+import Calamity.Gateway.Intents+import Calamity.Gateway.Types+import Calamity.HTTP.Internal.Ratelimit+import Calamity.Internal.ConstructorName+import Calamity.Internal.RunIntoIO+import qualified Calamity.Internal.SnowflakeMap as SM+import Calamity.Internal.UnixTimestamp+import Calamity.Internal.Updateable+import Calamity.Internal.Utils+import Calamity.Metrics.Eff+import Calamity.Types.LogEff+import Calamity.Types.Model.Channel+import Calamity.Types.Model.Guild+import Calamity.Types.Model.Presence (Presence (..))+import Calamity.Types.Model.User import qualified Calamity.Types.Model.Voice as V-import           Calamity.Types.Snowflake-import           Calamity.Types.Token-import           Calamity.Types.LogEff--import           Control.Concurrent.Chan.Unagi-import           Control.Concurrent.MVar-import           Control.Concurrent.STM-import           Control.Exception                 ( SomeException )-import           Control.Lens                      hiding ( (<.>) )-import           Control.Monad--import           Data.Default.Class-import           Data.Dynamic-import           Data.Foldable-import           Data.Generics.Product.Subtype-import           Data.IORef-import           Data.Maybe-import           Data.Proxy-import qualified Data.Text                         as S-import           Data.Time.Clock.POSIX--import qualified Di.Core                           as DC+import Calamity.Types.Snowflake+import Calamity.Types.Token+import Control.Concurrent.Chan.Unagi+import Control.Concurrent.MVar+import Control.Concurrent.STM+import Control.Exception (SomeException)+import Control.Lens hiding ((<.>))+import Control.Monad+import Data.Default.Class+import Data.Dynamic+import Data.Foldable+import Data.Generics.Product.Subtype+import Data.IORef+import Data.Maybe+import Data.Proxy+import qualified Data.Text as S+import Data.Time.Clock.POSIX import qualified Df1-import qualified DiPolysemy                        as Di--import           Fmt--import qualified Polysemy                          as P-import qualified Polysemy.Async                    as P-import qualified Polysemy.AtomicState              as P-import qualified Polysemy.Error                    as P-import qualified Polysemy.Fail                     as P-import qualified Polysemy.Reader                   as P-import qualified Polysemy.Resource                 as P--import           TextShow                          ( TextShow(showt) )+import qualified Di.Core as DC+import qualified DiPolysemy as Di+import qualified Polysemy as P+import qualified Polysemy.Async as P+import qualified Polysemy.AtomicState as P+import qualified Polysemy.Error as P+import qualified Polysemy.Fail as P+import qualified Polysemy.Reader as P+import qualified Polysemy.Resource as P+import PyF+import TextShow (TextShow (showt))  timeA :: P.Member (P.Embed IO) r => P.Sem r a -> P.Sem r (Double, a) timeA m = do@@ -343,7 +339,7 @@   r <- P.errorToIOFinal . P.fromExceptionSem @SomeException $ P.raise m   case r of     Right _ -> pure ()-    Left e -> debug $ "got exception: " +|| e ||+ ""+    Left e -> debug [fmt|got exception: {e:s}|]  handleEvent :: BotC r => Int -> DispatchData -> P.Sem r () handleEvent shardID data' = do@@ -364,7 +360,7 @@       (time, _) <- timeA . catchAllLogging $ P.embed action       void $ observeHistogram time eventHandleHisto     -- pattern match failures are usually stuff like events for uncached guilds, etc-    Left err      -> debug $ "Failed handling actions for event: " +| err |+ ""+    Left err      -> debug [fmt|Failed handling actions for event: {err:s}|]  handleEvent' :: BotC r               => EventHandlers@@ -602,7 +598,7 @@                     else mempty   pure $ userUpdates <> map ($ (oldMember, newMember)) (getEventHandlers @'GuildMemberUpdateEvt eh) -handleEvent' eh (TypingStart TypingStartData { channelID, guildID, userID, timestamp }) =+handleEvent' eh (TypingStart TypingStartData { channelID, guildID, userID, timestamp = UnixTimestamp timestamp }) =   case guildID of     Just gid -> do       Just guild <- getGuild gid@@ -674,7 +670,7 @@ updateCache (GuildMemberRemove GuildMemberRemoveData { guildID, user }) =   updateGuild guildID (#members %~ sans (getID user)) -updateCache (GuildMemberUpdate GuildMemberUpdateData { guildID, roles, user, nick }) = do+updateCache (GuildMemberUpdate GuildMemberUpdateData { guildID, roles = AesonVector roles, user, nick }) = do   setUser user   updateGuild guildID (#members . ix (getID user) %~ (#roles .~ roles) . (#nick .~ nick)) 

@@ -1,25 +1,20 @@ -- | Contains stuff for managing shards-module Calamity.Client.ShardManager-    ( shardBot ) where--import           Calamity.Client.Types-import           Calamity.Gateway-import           Calamity.HTTP-import           Calamity.Internal.Utils--import           Control.Concurrent.MVar-import           Control.Concurrent.STM-import           Control.Lens-import           Control.Monad--import           Data.Traversable--import           Fmt+module Calamity.Client.ShardManager (shardBot) where -import           Polysemy                    ( Sem )-import qualified Polysemy.Fail               as P-import qualified Polysemy                    as P-import qualified Polysemy.Reader             as P+import Calamity.Client.Types+import Calamity.Gateway+import Calamity.HTTP+import Calamity.Internal.Utils+import Control.Concurrent.MVar+import Control.Concurrent.STM+import Control.Lens+import Control.Monad+import Data.Traversable+import Polysemy (Sem)+import qualified Polysemy as P+import qualified Polysemy.Fail as P+import qualified Polysemy.Reader as P+import PyF  mapLeft :: (a -> c) -> Either a b -> Either c b mapLeft f (Left a) = Left $ f a@@ -43,10 +38,9 @@   let host = gateway ^. #url   P.embed $ putMVar numShardsVar numShards' -  info $ "Number of shards: " +| numShards' |+ ""+  info [fmt|Number of shards: {numShards'}|]    shards <- for [0 .. numShards' - 1] $ \id ->     newShard host id numShards' token initialStatus intents inc    P.embed . atomically $ writeTVar shardsVar shards-

@@ -29,7 +29,6 @@ import Calamity.Types.Model.Voice import Calamity.Types.Snowflake import Calamity.Types.Token-import Calamity.Types.UnixTimestamp  import Control.Concurrent.Async import Control.Concurrent.Chan.Unagi@@ -226,7 +225,7 @@   EHType 'RawMessageReactionAddEvt = ReactionEvtData   EHType 'RawMessageReactionRemoveEvt = ReactionEvtData   EHType 'RawMessageReactionRemoveAllEvt = Snowflake Message-  EHType 'TypingStartEvt = (Channel, Snowflake User, UnixTimestamp)+  EHType 'TypingStartEvt = (Channel, Snowflake User, UTCTime)   EHType 'UserUpdateEvt = (User, User)   EHType 'VoiceStateUpdateEvt = (Maybe VoiceState, VoiceState)   EHType ( 'CustomEvt a) = a

@@ -4,10 +4,10 @@ module Calamity.Commands (     module Calamity.Commands.Dsl,     module CalamityCommands.Error,-    module CalamityCommands.Handler,     module Calamity.Commands.Help,     module CalamityCommands.Parser,     module Calamity.Commands.Utils,+    module Calamity.Commands.Types,      -- * Commands     -- $commandDocs@@ -17,8 +17,8 @@ import Calamity.Commands.Dsl import Calamity.Commands.Help import Calamity.Commands.Utils+import Calamity.Commands.Types import CalamityCommands.Error-import CalamityCommands.Handler import CalamityCommands.Parser  {- $commandDocs

@@ -3,7 +3,7 @@  import Calamity.Internal.AesonThings import Calamity.Internal.ConstructorName-import Calamity.Internal.Utils ()+import Calamity.Internal.UnixTimestamp import Calamity.Types.Model.Channel import Calamity.Types.Model.Channel.UpdatedMessage import Calamity.Types.Model.Guild.Ban@@ -16,16 +16,13 @@ import Calamity.Types.Model.User import Calamity.Types.Model.Voice import Calamity.Types.Snowflake-import Calamity.Types.UnixTimestamp- import Data.Aeson+import Data.Kind (Type) import Data.Text.Lazy (Text) import Data.Time-import Data.Vector.Unboxing (Vector)--import GHC.Generics-import Data.Kind (Type) import Data.Typeable (Typeable)+import GHC.Generics+import Calamity.Internal.Utils  data CalamityEvent   = Dispatch@@ -33,8 +30,8 @@       -- ^ The shard that pushed this event       DispatchData       -- ^ The attached data-  | forall (a :: Type). Typeable a => Custom a-      -- ^ The data sent to the custom event+  | -- | The data sent to the custom event+    forall (a :: Type). Typeable a => Custom a   | ShutDown  data DispatchData@@ -113,7 +110,7 @@  data GuildMemberUpdateData = GuildMemberUpdateData   { guildID :: Snowflake Guild-  , roles :: Vector (Snowflake Role)+  , roles :: AesonVector (Snowflake Role)   , user :: User   , nick :: Maybe Text   }

@@ -33,7 +33,6 @@ import Data.Maybe import qualified Data.Text.Lazy as L import DiPolysemy hiding (debug, error, info)-import Fmt import qualified Network.Connection as NC import qualified Network.TLS as NT import qualified Network.TLS.Extra as NT@@ -55,6 +54,7 @@ import qualified System.X509 as X509 import TextShow (showtl) import Prelude hiding (error)+import PyF  runWebsocket ::   P.Members '[LogEff, P.Final IO, P.Embed IO] r =>@@ -67,7 +67,7 @@    -- We have to do this all ourself I think?   -- TODO: see if this isn't needed-  let logExc e = debug $ "runWebsocket raised with " +|| e ||+ ""+  let logExc e = debug [fmt|runWebsocket raised with {e:s}|]   logExc' <- bindSemToIO logExc   let handler e = do         void $ logExc' e@@ -130,7 +130,7 @@   case wsConn' of     Just wsConn -> do       let encodedData = A.encode data'-      debug $ "sending " +|| data' ||+ " encoded to " +|| encodedData ||+ " to gateway"+      debug [fmt|sending {data':s} encoded to {encodedData:s} to gateway|]       P.embed . sendTextData wsConn $ encodedData     Nothing -> debug "tried to send to closed WS" @@ -181,7 +181,7 @@        case msg of         Left (c, reason) -> do-          whenJust reason (\r -> error $ "Shard closed with reason: " <> r)+          whenJust reason (\r -> error [fmt|Shard closed with reason: {r}|])           P.embed . atomically $ writeTBMQueue outqueue (Control c)         Right msg' -> do           let decoded = A.eitherDecode msg'@@ -189,7 +189,7 @@             Right a ->               P.embed . atomically $ tryWriteTBMQueue' outqueue (Discord a)             Left e -> do-              error $ "Failed to decode: " +| e |+ ""+              error [fmt|Failed to decode: {e}|]               pure True           when r inner   outerloop :: ShardC r => Sem r ()@@ -197,7 +197,7 @@     shard :: Shard <- P.atomicGets (^. #shardS)     let host = shard ^. #gateway     let host' = fromMaybe host $ L.stripPrefix "wss://" host-    info $ "starting up shard " +| (shard ^. #shardID) |+ " of " +| (shard ^. #shardCount) |+ ""+    info [fmt|starting up shard {shardID shard} of {shardCount shard}|]      innerLoopVal <- runWebsocket host' "/?v=8&encoding=json" innerloop @@ -227,7 +227,7 @@      case (seqNum', sessionID') of       (Just n, Just s) -> do-        debug $ "Resuming shard (sessionID: " +| s |+ ", seq: " +| n |+ ")"+        debug [fmt|Resuming shard (sessionID: {s}, seq: {n})|]         sendToWs           ( Resume               ResumeData@@ -307,14 +307,14 @@           P.embed $ threadDelay (15 * 1000 * 1000)       P.throw ShardFlowRestart     Hello interval -> do-      info $ "Received hello, beginning to heartbeat at an interval of " +| interval |+ "ms"+      info [fmt|Received hello, beginning to heartbeat at an interval of {interval}ms|]       startHeartBeatLoop interval     HeartBeatAck -> do       debug "Received heartbeat ack"       P.atomicModify' (#hbResponse .~ True)   handleMsg (Control msg) = case msg of     SendPresence data' -> do-      debug $ "Sending presence: (" +|| data' ||+ ")"+      debug [fmt|Sending presence: ({data':s})|]       sendToWs $ StatusUpdate data'     RestartShard -> P.throw ShardFlowRestart     ShutDownShard -> P.throw ShardFlowShutDown@@ -340,7 +340,7 @@ sendHeartBeat :: ShardC r => Sem r () sendHeartBeat = do   sn <- P.atomicGets (^. #seqNum)-  debug $ "Sending heartbeat (seq: " +|| sn ||+ ")"+  debug [fmt|Sending heartbeat (seq: {sn:s})|]   sendToWs $ HeartBeat sn   P.atomicModify' (#hbResponse .~ False) 

@@ -26,8 +26,7 @@ import Calamity.HTTP.Internal.Request import Calamity.HTTP.Internal.Route import Calamity.Internal.AesonThings-import Calamity.Internal.IntColour ()-import Calamity.Internal.Utils ()+import Calamity.Internal.IntColour import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild import Calamity.Types.Model.User@@ -167,7 +166,7 @@ modifyGuildRolePermissions v = ModifyGuildRoleData $ H.fromList [("permissions", toJSON v)]  modifyGuildRoleColour :: Maybe (Colour Double) -> ModifyGuildRoleData-modifyGuildRoleColour v = ModifyGuildRoleData $ H.fromList [("colour", toJSON v)]+modifyGuildRoleColour v = ModifyGuildRoleData $ H.fromList [("colour", toJSON (IntColour <$> v))]  modifyGuildRoleHoist :: Maybe Bool -> ModifyGuildRoleData modifyGuildRoleHoist v = ModifyGuildRoleData $ H.fromList [("hoist", toJSON v)]

@@ -1,22 +1,21 @@ -- | Module containing ratelimit stuff module Calamity.HTTP.Internal.Ratelimit (-  newRateLimitState,-  doRequest,+    newRateLimitState,+    doRequest, ) where  import Calamity.Client.Types (BotC) import Calamity.HTTP.Internal.Route import Calamity.HTTP.Internal.Types import Calamity.Internal.Utils- import Control.Applicative import Control.Concurrent import Control.Concurrent.Event (Event) import qualified Control.Concurrent.Event as E import Control.Concurrent.STM+import qualified Control.Exception.Safe as Ex import Control.Lens import Control.Monad- import Data.Aeson import Data.Aeson.Lens import qualified Data.ByteString as B@@ -25,22 +24,16 @@ import qualified Data.Text.Lazy as LT import Data.Time import Data.Time.Clock.POSIX--import Fmt- import Network.HTTP.Client (responseStatus) import Network.HTTP.Req import Network.HTTP.Types- import Polysemy (Sem) import qualified Polysemy as P-+import PyF+import qualified StmContainers.Map as SC import Prelude hiding (error) import qualified Prelude -import qualified Control.Exception.Safe as Ex-import qualified StmContainers.Map as SC- newRateLimitState :: IO RateLimitState newRateLimitState = RateLimitState <$> SC.newIO <*> SC.newIO <*> E.newSet @@ -88,7 +81,7 @@       , -- we only ignore the previous 'remaining' if we've not reset yet and the         -- reset time has changed         remaining =-          if (isJust $ old ^. #resetTime) && (old ^. #resetKey /= new ^. #resetKey)+          if isJust (old ^. #resetTime) && (old ^. #resetKey /= new ^. #resetKey)             then min (old ^. #remaining) (new ^. #remaining)             else new ^. #remaining       , -- only take the new resetTime if it actually changed@@ -206,7 +199,7 @@       if           | statusIsSuccessful status -> do             let resp = responseBody r'-            debug $ "Got good response from discord: " +|| status ||+ ""+            debug [fmt|Got good response from discord: {status:s}|]             now <- P.embed getCurrentTime             let rlHeaders = buildBucketState now r'             pure $ Good resp rlHeaders@@ -220,13 +213,13 @@                 pure $ ServerError (statusCode status)           | statusIsClientError status -> do             let err = responseBody r'-            error $ "Something went wrong: " +|| err ||+ " response: " +|| r' ||+ ""+            error [fmt|Something went wrong: {err:s}, response: {r':s}|]             pure $ ClientError (statusCode status) err           | otherwise -> do-            debug $ "Got server error from discord: " +| statusCode status |+ ""+            debug [fmt|Got server error from discord: {statusCode status}|]             pure $ ServerError (statusCode status)     Left e -> do-      error $ "Something went wrong with the http client: " +| LT.pack e |+ ""+      error [fmt|Something went wrong with the http client: {e}|]       pure . InternalResponseError $ LT.pack e  -- | Parse a ratelimit header returning when it unlocks@@ -282,12 +275,12 @@     res <- action     case res of       Retry r | numRetries > maxRetries -> do-        debug $ "Request failed after " +| maxRetries |+ " retries."+        debug [fmt|Request failed after {maxRetries} retries|]         pure $ Left r       Retry _ ->         retryInner (numRetries + 1)       RFail r -> do-        debug "Request failed due to error response."+        debug "Request failed due to error response"         pure $ Left r       RGood r ->         pure $ Right r@@ -340,7 +333,7 @@           Nothing -> pure ()       pure $ RGood v     Ratelimited unlockWhen False (Just (bs, bk)) -> do-      debug $ "429 ratelimited on route, retrying at " +| unlockWhen |+ ""+      debug [fmt|429 ratelimited on route, retrying at {unlockWhen:s}|]        P.embed . atomically $ do         case rl of

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

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

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

@@ -16,14 +16,13 @@ import GHC.Exts (IsList) import GHC.Generics import TextShow-import qualified TextShow.Generic as TSG import Unsafe.Coerce  newtype SnowflakeMap a = SnowflakeMap   { unSnowflakeMap :: HashMap (Snowflake a) a   }-  deriving (Generic, Eq, Data, Ord, Show)-  deriving (TextShow) via TSG.FromGeneric (SnowflakeMap a)+  deriving stock (Generic, Eq, Data, Ord, Show)+  deriving (TextShow) via FromStringShow (SnowflakeMap a)   deriving newtype (IsList, Semigroup, Monoid)   deriving newtype (NFData, Hashable) 

@@ -0,0 +1,64 @@+-- | Internal newtype for deserializing timestamps+module Calamity.Internal.UnixTimestamp (+    UnixTimestamp (..),+    unixToMilliseconds,+    millisecondsToUnix,+) where++import Calamity.Internal.Utils ()+import Control.Arrow+import Control.DeepSeq (NFData)+import Data.Aeson+import Data.Aeson.Encoding (word64)+import Data.Time+import Data.Time.Clock.POSIX+import Data.Word+import GHC.Generics+import TextShow++newtype UnixTimestamp = UnixTimestamp+    { unUnixTimestamp :: UTCTime+    }+    deriving stock (Generic)+    deriving anyclass (NFData)+    deriving (Show) via UTCTime+    deriving (TextShow) via FromStringShow UTCTime++unixToMilliseconds :: UnixTimestamp -> Word64+unixToMilliseconds =+    unUnixTimestamp+        >>> utcTimeToPOSIXSeconds+        >>> toRational+        >>> (* 1000)+        >>> round++millisecondsToUnix :: Word64 -> UnixTimestamp+millisecondsToUnix =+    toRational+        >>> fromRational+        >>> (/ 1000)+        >>> posixSecondsToUTCTime+        >>> UnixTimestamp++instance ToJSON UnixTimestamp where+    toJSON =+        unUnixTimestamp+            >>> utcTimeToPOSIXSeconds+            >>> toRational+            >>> round+            >>> toJSON @Word64+    toEncoding =+        unUnixTimestamp+            >>> utcTimeToPOSIXSeconds+            >>> toRational+            >>> round+            >>> word64++instance FromJSON UnixTimestamp where+    parseJSON =+        withScientific "UnixTimestamp" $+            toRational+                >>> fromRational+                >>> posixSecondsToUTCTime+                >>> UnixTimestamp+                >>> pure

@@ -1,85 +1,83 @@-{-# OPTIONS_GHC -Wno-orphans #-}- -- | Internal utilities and instances-module Calamity.Internal.Utils-    ( whileMFinalIO-    , untilJustFinalIO-    , whenJust-    , whenM-    , unlessM-    , lastMaybe-    , leftToMaybe-    , rightToMaybe-    , justToEither-    , (<<$>>)-    , (<<*>>)-    , (<.>)-    , debug-    , info-    , Calamity.Internal.Utils.error-    , swap ) where--import           Calamity.Types.LogEff-import           Calamity.Internal.RunIntoIO--import           Control.Applicative--import           Data.Default.Class-import qualified Data.HashMap.Lazy     as LH-import qualified Data.Map              as M-import           Data.Semigroup        ( Last(..) )-import           Data.Text.Lazy-import           Data.Time-import qualified Data.Vector.Unboxing  as VU-import           Data.Vector.Unboxing  ( Vector )-import           Data.Aeson--import qualified DiPolysemy            as Di+module Calamity.Internal.Utils (+  whileMFinalIO,+  untilJustFinalIO,+  whenJust,+  whenM,+  unlessM,+  lastMaybe,+  leftToMaybe,+  rightToMaybe,+  justToEither,+  (<<$>>),+  (<<*>>),+  (<.>),+  debug,+  info,+  Calamity.Internal.Utils.error,+  swap,+  DefaultingMap (..),+  AesonVector (..),+  CalamityFromStringShow (..),+) where -import qualified Polysemy              as P+import Calamity.Internal.RunIntoIO+import Calamity.Types.LogEff+import Control.Applicative+import Data.Aeson+import Data.Default.Class+import qualified Data.Map as M+import Data.Semigroup (Last (..))+import Data.Text.Lazy+import qualified Data.Vector.Unboxing as VU+import qualified DiPolysemy as Di+import qualified Polysemy as P+import TextShow -import           TextShow-import Data.Colour (Colour)+{- | Like whileM, but stateful effects are not preserved to mitigate memory leaks --- | Like whileM, but stateful effects are not preserved to mitigate memory leaks------ This means Polysemy.Error won't work to break the loop, etc.--- Instead, Error/Alternative will just result in the loop quitting.+ 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 action = do   action' <- runSemToIO action   P.embedFinal $ go action'-  where go action' = do-          r <- action'-          case r of-            Just True ->-              go action'-            _ ->-              pure ()+ where+  go action' = do+    r <- action'+    case r of+      Just True ->+        go action'+      _ ->+        pure () --- | Like untilJust, but stateful effects are not preserved to mitigate memory leaks------ This means Polysemy.Error won't work to break the loop, etc.--- Instead, Error/Alternative will just result in another loop.+{- | Like untilJust, but stateful effects are not preserved to mitigate memory leaks++ 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 action = do   action' <- runSemToIO action   P.embedFinal $ go action'-  where go action' = do-          r <- action'-          case r of-            Just (Just a) ->-              pure a-            _ ->-              go action'+ where+  go action' = do+    r <- action'+    case r of+      Just (Just a) ->+        pure a+      _ ->+        go action'  whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () whenJust = flip $ maybe (pure ())  whenM :: Monad m => m Bool -> m () -> m ()-whenM p m = p >>= \case-  True  -> m-  False -> pure ()+whenM p m =+  p >>= \case+    True -> m+    False -> pure ()  unlessM :: Monad m => m Bool -> m () -> m () unlessM = whenM . (not <$>)@@ -89,15 +87,15 @@  leftToMaybe :: Either e a -> Maybe e leftToMaybe (Left x) = Just x-leftToMaybe _        = Nothing+leftToMaybe _ = Nothing  rightToMaybe :: Either e a -> Maybe a rightToMaybe (Right x) = Just x-rightToMaybe _         = Nothing+rightToMaybe _ = Nothing  justToEither :: Maybe e -> Either e () justToEither (Just x) = Left x-justToEither _        = Right ()+justToEither _ = Right ()  (<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) (<<$>>) = fmap . fmap@@ -126,27 +124,24 @@ swap :: (a, b) -> (b, a) swap ~(a, b) = (b, a) -instance TextShow UTCTime where-  showb = fromString . show--instance (TextShow a, VU.Unboxable a) => TextShow (Vector a) where-  showb = showbList . VU.toList+newtype DefaultingMap k v = DefaultingMap {unDefaultingMap :: M.Map k v} -instance (Show k, Show v) => TextShow (LH.HashMap k v) where-  showb = fromString . show+instance Default (DefaultingMap k v) where+  def = DefaultingMap M.empty -instance (Show k, Show v) => TextShow (M.Map k v) where-  showb = fromString . show+newtype AesonVector a = AesonVector {unAesonVector :: VU.Vector a}+  deriving (Show) via VU.Vector a -instance (Show a, Fractional a) => TextShow (Colour a) where-  showb = fromString . show+instance (FromJSON a, VU.Unboxable a) => FromJSON (AesonVector a) where+  parseJSON = (AesonVector . VU.fromList <$>) . parseJSON -instance Default (M.Map k v) where-    def = M.empty+instance (ToJSON a, VU.Unboxable a) => ToJSON (AesonVector a) where+  toJSON = toJSON . VU.toList . unAesonVector+  toEncoding = toEncoding . VU.toList . unAesonVector -instance (FromJSON a, VU.Unboxable a) => FromJSON (VU.Vector a) where-  parseJSON = (VU.fromList <$>) . parseJSON+instance (TextShow a, VU.Unboxable a) => TextShow (AesonVector a) where+  showb = showbList . VU.toList . unAesonVector -instance (ToJSON a, VU.Unboxable a) => ToJSON (VU.Vector a) where-  toJSON = toJSON . VU.toList-  toEncoding = toEncoding . VU.toList+newtype CalamityFromStringShow a = CalamityFromStringShow {unCalamityFromStringShow :: a}+  deriving (FromJSON, ToJSON) via a+  deriving TextShow via FromStringShow a

@@ -1,62 +1,75 @@ {-# LANGUAGE TemplateHaskell #-}  -- | Effect for handling metrics-module Calamity.Metrics.Eff-    ( Counter-    , Gauge-    , Histogram-    , HistogramSample(..)-    , MetricEff(..)-    , registerCounter-    , registerGauge-    , registerHistogram-    , addCounter-    , modifyGauge-    , observeHistogram ) where--import           Calamity.Internal.Utils   ()-import           Calamity.Metrics.Internal--import           Data.Default.Class-import           Data.Map-import           Data.Text--import           GHC.Generics+module Calamity.Metrics.Eff (+  Counter,+  Gauge,+  Histogram,+  HistogramSample (..),+  MetricEff (..),+  registerCounter,+  registerGauge,+  registerHistogram,+  addCounter,+  modifyGauge,+  observeHistogram,+) where -import           Polysemy+import Calamity.Internal.Utils (DefaultingMap)+import Calamity.Metrics.Internal+import Data.Default.Class+import Data.Map+import Data.Text+import GHC.Generics+import Polysemy+import TextShow+import Calamity.Internal.OverriddenVia -import           TextShow-import qualified TextShow.Generic          as TSG+data HistogramSample' = HistogramSample'+  { buckets :: DefaultingMap Double Double+  , sum :: Double+  , count :: Int+  }+  deriving (Generic)+  deriving (Default)  data HistogramSample = HistogramSample   { buckets :: Map Double Double-  , sum     :: Double-  , count   :: Int+  , sum :: Double+  , count :: Int   }-  deriving ( Eq, Show, Generic, Default )-  deriving ( TextShow ) via TSG.FromGeneric HistogramSample+  deriving (Eq, Show, Generic)+  deriving (Default) via OverriddenVia HistogramSample HistogramSample+  deriving+    (TextShow)+    via FromStringShow HistogramSample  data MetricEff m a where   -- | Register a 'Counter'-  RegisterCounter :: Text -- ^ Name-    -> [(Text, Text)] -- ^ Labels-    -> MetricEff m Counter-+  RegisterCounter ::+    -- | Name+    Text ->+    -- | Labels+    [(Text, Text)] ->+    MetricEff m Counter   -- | Register a 'Gauge'-  RegisterGauge :: Text -- ^ Name-    -> [(Text, Text)] -- ^ Labels-    -> MetricEff m Gauge-+  RegisterGauge ::+    -- | Name+    Text ->+    -- | Labels+    [(Text, Text)] ->+    MetricEff m Gauge   -- | Register a 'Histogram'-  RegisterHistogram :: Text -- ^ Name-    -> [(Text, Text)] -- ^ Labels-    -> [Double] -- ^ Upper bounds-    -> MetricEff m Histogram-+  RegisterHistogram ::+    -- | Name+    Text ->+    -- | Labels+    [(Text, Text)] ->+    -- | Upper bounds+    [Double] ->+    MetricEff m Histogram   AddCounter :: Int -> Counter -> MetricEff m Int-   ModifyGauge :: (Double -> Double) -> Gauge -> MetricEff m Double-   ObserveHistogram :: Double -> Histogram -> MetricEff m HistogramSample  makeSem ''MetricEff

@@ -6,7 +6,6 @@     , module Calamity.Types.Token     , module Calamity.Types.Tellable     , module Calamity.Types.Upgradeable-    , module Calamity.Types.UnixTimestamp     -- * Types     -- $typesDocs     ) where@@ -17,7 +16,6 @@ import           Calamity.Types.Token import           Calamity.Types.Tellable import           Calamity.Types.Upgradeable-import           Calamity.Types.UnixTimestamp  -- $typesDocs --

@@ -2,34 +2,41 @@ module Calamity.Types.Model.Channel.DM (DMChannel (..)) where  import Calamity.Internal.AesonThings-import Calamity.Internal.Utils ()+import Calamity.Internal.OverriddenVia+import Calamity.Internal.Utils import {-# SOURCE #-} Calamity.Types.Model.Channel import {-# SOURCE #-} Calamity.Types.Model.Channel.Message import Calamity.Types.Model.User import Calamity.Types.Snowflake-+import Control.DeepSeq (NFData) import Data.Aeson import Data.Time import Data.Vector.Unboxing (Vector)- import GHC.Generics--import Control.DeepSeq (NFData) import TextShow import qualified TextShow.Generic as TSG -data DMChannel = DMChannel+data DMChannel' = DMChannel'   { id :: Snowflake DMChannel   , lastMessageID :: Maybe (Snowflake Message)-  , lastPinTimestamp :: Maybe UTCTime-  , recipients :: Vector (Snowflake User)+  , lastPinTimestamp :: Maybe (CalamityFromStringShow UTCTime)+  , recipients :: AesonVector (Snowflake User)   }-  deriving (Show, Eq, Generic, NFData)-  deriving (TextShow) via TSG.FromGeneric DMChannel+  deriving (Generic)+  deriving (TextShow) via TSG.FromGeneric DMChannel'   deriving     (FromJSON)     via WithSpecialCases           '["recipients" `ExtractArrayField` "id"]-          DMChannel+          DMChannel'++data DMChannel = DMChannel+  { id :: Snowflake DMChannel+  , lastMessageID :: Maybe (Snowflake Message)+  , lastPinTimestamp :: Maybe UTCTime+  , recipients :: Vector (Snowflake User)+  }+  deriving (Show, Eq, Generic, NFData)+  deriving (TextShow, FromJSON) via OverriddenVia DMChannel DMChannel'   deriving (HasID DMChannel) via HasIDField "id" DMChannel   deriving (HasID Channel) via HasIDFieldCoerce' "id" DMChannel

@@ -17,11 +17,10 @@ ) where  import Calamity.Internal.AesonThings-import Calamity.Internal.IntColour ()-import Calamity.Internal.Utils ()-+import Calamity.Internal.IntColour+import Calamity.Internal.OverriddenVia+import Calamity.Internal.Utils import Control.Lens- import Data.Aeson import Data.Colour (Colour) import Data.Default.Class@@ -30,12 +29,30 @@ import Data.Text.Lazy (Text) import Data.Time import Data.Word- import GHC.Generics- import TextShow import qualified TextShow.Generic as TSG +data Embed' = Embed'+    { title :: Maybe Text+    , type_ :: Maybe Text+    , description :: Maybe Text+    , url :: Maybe Text+    , timestamp :: Maybe (CalamityFromStringShow UTCTime)+    , color :: Maybe IntColour+    , footer :: Maybe EmbedFooter+    , image :: Maybe EmbedImage+    , thumbnail :: Maybe EmbedThumbnail+    , video :: Maybe EmbedVideo+    , provider :: Maybe EmbedProvider+    , author :: Maybe EmbedAuthor+    , fields :: [EmbedField]+    }+    deriving (Generic)+    deriving (FromJSON) via WithSpecialCases '[IfNoneThen "fields" DefaultToEmptyArray] Embed'+    deriving (ToJSON) via CalamityJSON Embed'+    deriving (TextShow) via TSG.FromGeneric Embed'+ data Embed = Embed     { title :: Maybe Text     , type_ :: Maybe Text@@ -52,9 +69,7 @@     , fields :: [EmbedField]     }     deriving (Eq, Show, Generic, Default)-    deriving (TextShow) via TSG.FromGeneric Embed-    deriving (FromJSON) via WithSpecialCases '[IfNoneThen "fields" DefaultToEmptyArray] Embed-    deriving (ToJSON) via CalamityJSON Embed+    deriving (TextShow, FromJSON, ToJSON) via OverriddenVia Embed Embed'  instance Semigroup Embed where     l <> r =

@@ -1,36 +1,46 @@ -- | A Group Group channel-module Calamity.Types.Model.Channel.Group-    ( GroupChannel(..) ) where+module Calamity.Types.Model.Channel.Group (GroupChannel (..)) where -import           Calamity.Internal.AesonThings-import           Calamity.Internal.Utils              ()+import Calamity.Internal.AesonThings+import Calamity.Internal.Utils import {-# SOURCE #-} Calamity.Types.Model.Channel import {-# SOURCE #-} Calamity.Types.Model.Channel.Message-import           Calamity.Types.Model.User-import           Calamity.Types.Snowflake--import           Data.Aeson-import           Data.Text.Lazy                       ( Text )-import           Data.Time-import           Data.Vector.Unboxing                 ( Vector )+import Calamity.Types.Model.User+import Calamity.Types.Snowflake -import           GHC.Generics+import Calamity.Internal.OverriddenVia+import Data.Aeson+import Data.Text.Lazy (Text)+import Data.Time+import Data.Vector.Unboxing (Vector)+import GHC.Generics+import TextShow+import qualified TextShow.Generic as TSG -import           TextShow-import qualified TextShow.Generic                     as TSG+data GroupChannel' = GroupChannel'+  { id :: Snowflake GroupChannel+  , ownerID :: Snowflake User+  , lastMessageID :: Maybe (Snowflake Message)+  , lastPinTimestamp :: Maybe (CalamityFromStringShow UTCTime)+  , icon :: Maybe Text+  , recipients :: AesonVector (Snowflake User)+  , name :: Text+  }+  deriving (Generic)+  deriving (TextShow) via TSG.FromGeneric GroupChannel'+  deriving (ToJSON, FromJSON) via CalamityJSON GroupChannel'  data GroupChannel = GroupChannel-  { id               :: Snowflake GroupChannel-  , ownerID          :: Snowflake User-  , lastMessageID    :: Maybe (Snowflake Message)+  { id :: Snowflake GroupChannel+  , ownerID :: Snowflake User+  , lastMessageID :: Maybe (Snowflake Message)   , lastPinTimestamp :: Maybe UTCTime-  , icon             :: Maybe Text-  , recipients       :: Vector (Snowflake User)-  , name             :: Text+  , icon :: Maybe Text+  , recipients :: Vector (Snowflake User)+  , name :: Text   }-  deriving ( Show, Eq, Generic )-  deriving ( TextShow ) via TSG.FromGeneric GroupChannel-  deriving ( ToJSON, FromJSON ) via CalamityJSON GroupChannel-  deriving ( HasID GroupChannel ) via HasIDField "id" GroupChannel-  deriving ( HasID Channel ) via HasIDFieldCoerce' "id" GroupChannel-  deriving ( HasID User ) via HasIDField "ownerID" GroupChannel+  deriving (Show, Eq, Generic)+  deriving (TextShow, ToJSON, FromJSON) via OverriddenVia GroupChannel GroupChannel'+  deriving (HasID GroupChannel) via HasIDField "id" GroupChannel+  deriving (HasID Channel) via HasIDFieldCoerce' "id" GroupChannel+  deriving (HasID User) via HasIDField "ownerID" GroupChannel

@@ -3,7 +3,7 @@  import Calamity.Internal.AesonThings import Calamity.Internal.SnowflakeMap (SnowflakeMap)-import Calamity.Internal.Utils ()+import Calamity.Internal.Utils import {-# SOURCE #-} Calamity.Types.Model.Channel import {-# SOURCE #-} Calamity.Types.Model.Channel.Guild.Category import {-# SOURCE #-} Calamity.Types.Model.Channel.Message@@ -17,7 +17,25 @@ import GHC.Generics import TextShow import qualified TextShow.Generic as TSG+import Calamity.Internal.OverriddenVia +data TextChannel' = TextChannel'+  { id :: Snowflake TextChannel+  , guildID :: Snowflake Guild+  , position :: Int+  , permissionOverwrites :: SnowflakeMap Overwrite+  , name :: Text+  , topic :: Maybe Text+  , nsfw :: Bool+  , lastMessageID :: Maybe (Snowflake Message)+  , lastPinTimestamp :: Maybe (CalamityFromStringShow UTCTime)+  , rateLimitPerUser :: Maybe Int+  , parentID :: Maybe (Snowflake Category)+  }+  deriving (Generic)+  deriving (TextShow) via TSG.FromGeneric TextChannel'++ data TextChannel = TextChannel   { id :: Snowflake TextChannel   , guildID :: Snowflake Guild@@ -32,8 +50,8 @@   , parentID :: Maybe (Snowflake Category)   }   deriving (Show, Eq, Generic, NFData)-  deriving (TextShow) via TSG.FromGeneric TextChannel   deriving (ToJSON) via CalamityJSON TextChannel+  deriving (TextShow) via OverriddenVia TextChannel TextChannel   deriving     (FromJSON)     via WithSpecialCases

@@ -6,7 +6,8 @@ ) where  import Calamity.Internal.AesonThings-import Calamity.Internal.Utils ()+import Calamity.Internal.OverriddenVia+import Calamity.Internal.Utils import {-# SOURCE #-} Calamity.Types.Model.Channel import Calamity.Types.Model.Channel.Attachment import Calamity.Types.Model.Channel.Embed@@ -16,19 +17,56 @@ import Calamity.Types.Model.Guild.Role import Calamity.Types.Model.User import Calamity.Types.Snowflake- import Data.Aeson import Data.Scientific import Data.Text.Lazy (Text) import Data.Time import qualified Data.Vector.Unboxing as UV--import GHC.Generics- import Data.Word (Word64)+import GHC.Generics import TextShow import qualified TextShow.Generic as TSG +data Message' = Message'+  { id :: Snowflake Message+  , channelID :: Snowflake Channel+  , guildID :: Maybe (Snowflake Guild)+  , author :: Snowflake User+  , content :: Text+  , timestamp :: CalamityFromStringShow UTCTime+  , editedTimestamp :: Maybe (CalamityFromStringShow UTCTime)+  , tts :: Bool+  , mentionEveryone :: Bool+  , mentions :: AesonVector (Snowflake User)+  , mentionRoles :: AesonVector (Snowflake Role)+  , mentionChannels :: Maybe (AesonVector (Snowflake Channel))+  , attachments :: ![Attachment]+  , embeds :: ![Embed]+  , reactions :: ![Reaction]+  , nonce :: Maybe (Snowflake Message)+  , pinned :: Bool+  , webhookID :: Maybe (Snowflake Webhook)+  , type_ :: !MessageType+  , activity :: Maybe (CalamityFromStringShow Object)+  , application :: Maybe (CalamityFromStringShow Object)+  , messageReference :: Maybe MessageReference+  , flags :: Word64+  , stickers :: Maybe [CalamityFromStringShow Object]+  , referencedMessage :: Maybe Message+  , interaction :: Maybe (CalamityFromStringShow Object)+  }+  deriving (Generic)+  deriving (TextShow) via TSG.FromGeneric Message'+  deriving+    (FromJSON)+    via WithSpecialCases+          '[ "author" `ExtractFieldFrom` "id"+           , "mentions" `ExtractArrayField` "id"+           , "mention_channels" `ExtractArrayField` "id"+           , "reactions" `IfNoneThen` DefaultToEmptyArray+           ]+          Message'+ data Message = Message   { id :: Snowflake Message   , channelID :: Snowflake Channel@@ -58,16 +96,7 @@   , interaction :: Maybe Object   }   deriving (Eq, Show, Generic)-  deriving (TextShow) via TSG.FromGeneric Message-  deriving-    (FromJSON)-    via WithSpecialCases-          '[ "author" `ExtractFieldFrom` "id"-           , "mentions" `ExtractArrayField` "id"-           , "mention_channels" `ExtractArrayField` "id"-           , "reactions" `IfNoneThen` DefaultToEmptyArray-           ]-          Message+  deriving (TextShow, FromJSON) via OverriddenVia Message Message'   deriving (HasID Message) via HasIDField "id" Message   deriving (HasID Channel) via HasIDField "channelID" Message   deriving (HasID User) via HasIDField "author" Message

@@ -4,7 +4,8 @@ ) where  import Calamity.Internal.AesonThings-import Calamity.Internal.Utils ()+import Calamity.Internal.OverriddenVia+import Calamity.Internal.Utils import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild.Role import Calamity.Types.Model.User@@ -17,23 +18,23 @@ import TextShow import qualified TextShow.Generic as TSG -data UpdatedMessage = UpdatedMessage+data UpdatedMessage' = UpdatedMessage'     { id :: Snowflake Message     , channelID :: Snowflake Channel     , content :: Maybe Text-    , editedTimestamp :: Maybe UTCTime+    , editedTimestamp :: Maybe (CalamityFromStringShow UTCTime)     , tts :: Maybe Bool     , mentionEveryone :: Maybe Bool-    , mentions :: Maybe (UV.Vector (Snowflake User))-    , mentionRoles :: Maybe (UV.Vector (Snowflake Role))-    , mentionChannels :: Maybe (UV.Vector (Snowflake Channel))+    , mentions :: Maybe (AesonVector (Snowflake User))+    , mentionRoles :: Maybe (AesonVector (Snowflake Role))+    , mentionChannels :: Maybe (AesonVector (Snowflake Channel))     , attachments :: !(Maybe [Attachment])     , embeds :: Maybe [Embed]     , reactions :: Maybe [Reaction]     , pinned :: Maybe Bool     }-    deriving (Eq, Show, Generic)-    deriving (TextShow) via TSG.FromGeneric UpdatedMessage+    deriving (Generic)+    deriving (TextShow) via TSG.FromGeneric UpdatedMessage'     deriving         (FromJSON)         via WithSpecialCases@@ -41,6 +42,24 @@                  , "mentions" `ExtractArrayField` "id"                  , "mention_channels" `ExtractArrayField` "id"                  ]-                UpdatedMessage+                UpdatedMessage'++data UpdatedMessage = UpdatedMessage+    { id :: Snowflake Message+    , channelID :: Snowflake Channel+    , content :: Maybe Text+    , editedTimestamp :: Maybe UTCTime+    , tts :: Maybe Bool+    , mentionEveryone :: Maybe Bool+    , mentions :: Maybe (UV.Vector (Snowflake User))+    , mentionRoles :: Maybe (UV.Vector (Snowflake Role))+    , mentionChannels :: Maybe (UV.Vector (Snowflake Channel))+    , attachments :: !(Maybe [Attachment])+    , embeds :: Maybe [Embed]+    , reactions :: Maybe [Reaction]+    , pinned :: Maybe Bool+    }+    deriving (Eq, Show, Generic)+    deriving (TextShow, FromJSON) via OverriddenVia UpdatedMessage UpdatedMessage'     deriving (HasID Message) via HasIDField "id" UpdatedMessage     deriving (HasID Channel) via HasIDField "channelID" UpdatedMessage

@@ -7,42 +7,52 @@ ) where  import Calamity.Internal.AesonThings-import Calamity.Internal.Utils ()+import Calamity.Internal.OverriddenVia+import Calamity.Internal.Utils import Calamity.Types.Model.Guild.Role import Calamity.Types.Model.User import Calamity.Types.Snowflake-+import Control.DeepSeq (NFData) import Data.Aeson+import Data.Generics.Product import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as L import Data.Vector.Unboxing (Vector)- import GHC.Generics--import Control.DeepSeq (NFData)-import Data.Generics.Product import TextShow import qualified TextShow.Generic as TSG -data Emoji = Emoji+data Emoji' = Emoji'   { id :: Snowflake Emoji   , name :: Text-  , roles :: Vector (Snowflake Role)+  , roles :: AesonVector (Snowflake Role)   , user :: Maybe (Snowflake User)   , requireColons :: Bool   , managed :: Bool   , animated :: Bool   }-  deriving (Eq, Show, Generic, NFData)-  deriving (TextShow) via TSG.FromGeneric Emoji-  deriving (ToJSON) via CalamityJSON Emoji+  deriving (Generic)+  deriving (TextShow) via TSG.FromGeneric Emoji'+  deriving (ToJSON) via CalamityJSON Emoji'   deriving     (FromJSON)     via WithSpecialCases           '[ "user" `ExtractFieldFrom` "id"            , "roles" `IfNoneThen` DefaultToEmptyArray            ]-          Emoji+          Emoji'++data Emoji = Emoji+  { id :: Snowflake Emoji+  , name :: Text+  , roles :: Vector (Snowflake Role)+  , user :: Maybe (Snowflake User)+  , requireColons :: Bool+  , managed :: Bool+  , animated :: Bool+  }+  deriving (Eq, Show, Generic, NFData)+  deriving (TextShow, ToJSON, FromJSON) via OverriddenVia Emoji Emoji'   deriving (HasID Emoji) via HasIDField "id" Emoji  emojiAsRawEmoji :: Emoji -> RawEmoji

@@ -6,9 +6,10 @@ ) where  import Calamity.Internal.AesonThings+import Calamity.Internal.OverriddenVia import Calamity.Internal.SnowflakeMap (SnowflakeMap) import qualified Calamity.Internal.SnowflakeMap as SM-import Calamity.Internal.Utils ()+import Calamity.Internal.Utils import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild.Emoji import {-# SOURCE #-} Calamity.Types.Model.Guild.Member@@ -21,10 +22,10 @@ import Control.Lens ((^.)) import Data.Aeson import Data.Aeson.Types-import Data.Maybe import Data.Generics.Product.Fields import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as LH+import Data.Maybe import Data.Text.Lazy (Text) import Data.Time import Data.Word@@ -32,6 +33,43 @@ import TextShow import qualified TextShow.Generic as TSG +data Guild' = Guild'+  { id :: Snowflake Guild+  , name :: Text+  , icon :: Maybe Text+  , splash :: Maybe Text+  , owner :: Maybe Bool+  , ownerID :: Snowflake User+  , permissions :: Word64+  , region :: Text+  , afkChannelID :: Maybe (Snowflake GuildChannel)+  , afkTimeout :: Int+  , embedEnabled :: Bool+  , embedChannelID :: Maybe (Snowflake GuildChannel)+  , verificationLevel :: Int+  , defaultMessageNotifications :: Int+  , explicitContentFilter :: Int+  , roles :: SnowflakeMap Role+  , emojis :: SnowflakeMap Emoji+  , features :: [Text]+  , mfaLevel :: Int+  , applicationID :: Maybe (Snowflake User)+  , widgetEnabled :: Bool+  , widgetChannelID :: Maybe (Snowflake GuildChannel)+  , systemChannelID :: Maybe (Snowflake GuildChannel)+  , -- NOTE: Below are only sent on GuildCreate+    joinedAt :: Maybe (CalamityFromStringShow UTCTime)+  , large :: Bool+  , unavailable :: Bool+  , memberCount :: Int+  , voiceStates :: [VoiceState]+  , members :: SnowflakeMap Member+  , channels :: SnowflakeMap GuildChannel+  , presences :: CalamityFromStringShow (HashMap (Snowflake User) Presence)+  }+  deriving (Generic)+  deriving (TextShow) via TSG.FromGeneric Guild'+ data Guild = Guild   { id :: Snowflake Guild   , name :: Text@@ -67,7 +105,7 @@   , presences :: HashMap (Snowflake User) Presence   }   deriving (Eq, Show, Generic, NFData)-  deriving (TextShow) via TSG.FromGeneric Guild+  deriving (TextShow) via OverriddenVia Guild Guild'   deriving (HasID Guild) via HasIDField "id" Guild  instance FromJSON Guild where@@ -85,11 +123,15 @@      presences' <- do       presences' <- v .: "presences"-      pure . LH.fromList . mapMaybe (parseMaybe @Object @(Snowflake User, Presence)-          ( \m -> do-              p <- parseJSON $ Object (m <> "guild_id" .= id)-              pure (getID $ p ^. field @"user", p)-          )) $ presences'+      pure . LH.fromList+        . mapMaybe+          ( parseMaybe @Object @(Snowflake User, Presence)+              ( \m -> do+                  p <- parseJSON $ Object (m <> "guild_id" .= id)+                  pure (getID $ p ^. field @"user", p)+              )+          )+        $ presences'      Guild id       <$> v .: "name"

@@ -2,7 +2,8 @@ module Calamity.Types.Model.Guild.Member (Member (..)) where  import Calamity.Internal.AesonThings-import Calamity.Internal.Utils ()+import Calamity.Internal.OverriddenVia+import Calamity.Internal.Utils import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild import Calamity.Types.Model.Guild.Role import Calamity.Types.Model.User@@ -17,7 +18,7 @@ import TextShow import qualified TextShow.Generic as TSG -data Member = Member+data Member' = Member'   { id :: Snowflake User   , username :: Text   , discriminator :: Text@@ -30,13 +31,13 @@   , premiumType :: Maybe Word64   , guildID :: Snowflake Guild   , nick :: Maybe Text-  , roles :: Vector (Snowflake Role)-  , joinedAt :: UTCTime+  , roles :: AesonVector (Snowflake Role)+  , joinedAt :: CalamityFromStringShow UTCTime   , deaf :: Bool   , mute :: Bool   }-  deriving (Eq, Show, Generic, NFData)-  deriving (TextShow) via TSG.FromGeneric Member+  deriving (Generic)+  deriving (TextShow) via TSG.FromGeneric Member'   deriving     (FromJSON)     via WithSpecialCases@@ -53,7 +54,28 @@                               , "premium_type"                               ]            ]-          Member+          Member'++data Member = Member+  { id :: Snowflake User+  , username :: Text+  , discriminator :: Text+  , bot :: Maybe Bool+  , avatar :: Maybe Text+  , mfaEnabled :: Maybe Bool+  , verified :: Maybe Bool+  , email :: Maybe Text+  , flags :: Maybe Word64+  , premiumType :: Maybe Word64+  , guildID :: Snowflake Guild+  , nick :: Maybe Text+  , roles :: Vector (Snowflake Role)+  , joinedAt :: UTCTime+  , deaf :: Bool+  , mute :: Bool+  }+  deriving (Eq, Show, Generic, NFData)+  deriving (TextShow, FromJSON) via OverriddenVia Member Member'   deriving (HasID Guild) via HasIDField "guildID" Member   deriving (HasID Member) via HasIDFieldCoerce "id" Member User   deriving (HasID User) via HasIDField "id" Member

@@ -2,8 +2,7 @@ module Calamity.Types.Model.Guild.Role (Role (..)) where  import Calamity.Internal.AesonThings-import Calamity.Internal.IntColour ()-import Calamity.Internal.Utils ()+import Calamity.Internal.IntColour import Calamity.Types.Model.Guild.Permissions import Calamity.Types.Snowflake @@ -16,7 +15,22 @@ import Control.DeepSeq (NFData (rnf), rwhnf) import TextShow import qualified TextShow.Generic as TSG+import Calamity.Internal.OverriddenVia +data Role' = Role'+  { id :: Snowflake Role+  , name :: Text+  , color :: IntColour+  , hoist :: Bool+  , position :: Int+  , permissions :: Permissions+  , managed :: Bool+  , mentionable :: Bool+  }+  deriving (Generic)+  deriving (TextShow) via TSG.FromGeneric Role'+  deriving (ToJSON, FromJSON) via CalamityJSON Role'+ data Role = Role   { id :: Snowflake Role   , name :: Text@@ -28,8 +42,7 @@   , mentionable :: Bool   }   deriving (Eq, Show, Generic)-  deriving (TextShow) via TSG.FromGeneric Role-  deriving (ToJSON, FromJSON) via CalamityJSON Role+  deriving (TextShow, FromJSON, ToJSON) via OverriddenVia Role Role'   deriving (HasID Role) via HasIDField "id" Role  instance NFData Role where

@@ -10,13 +10,14 @@ ) where  import Calamity.Internal.AesonThings-import Calamity.Internal.Utils+import Calamity.Internal.OverriddenVia+import Calamity.Internal.UnixTimestamp import Calamity.Types.Snowflake-import Calamity.Types.UnixTimestamp import Control.DeepSeq (NFData) import Data.Aeson import Data.Scientific import Data.Text.Lazy (Text)+import Data.Time (UTCTime) import Data.Word import GHC.Generics import TextShow@@ -84,24 +85,20 @@     , flags = Nothing     } -data ActivityTimestamps = ActivityTimestamps+data ActivityTimestamps' = ActivityTimestamps'   { start :: !(Maybe UnixTimestamp)   , end :: !(Maybe UnixTimestamp)   }-  deriving (Eq, Show, Generic, NFData)-  deriving (TextShow) via TSG.FromGeneric ActivityTimestamps--instance ToJSON ActivityTimestamps where-  toJSON ActivityTimestamps{start, end} =-    object-      ["start" .= (unixToMilliseconds <$> start), "end" .= (unixToMilliseconds <$> end)]--instance FromJSON ActivityTimestamps where-  parseJSON = withObject "ActivityTimestamps" $ \v -> do-    start <- millisecondsToUnix <<$>> v .:? "start"-    end <- millisecondsToUnix <<$>> v .:? "end"+  deriving (Generic, NFData)+  deriving (ToJSON, FromJSON) via CalamityJSON ActivityTimestamps'+  deriving (TextShow) via TSG.FromGeneric ActivityTimestamps' -    pure $ ActivityTimestamps start end+data ActivityTimestamps = ActivityTimestamps+  { start :: !(Maybe UTCTime)+  , end :: !(Maybe UTCTime)+  }+  deriving (Eq, Show, Generic, NFData)+  deriving (TextShow, ToJSON, FromJSON) via OverriddenVia ActivityTimestamps ActivityTimestamps'  data ActivityParty = ActivityParty   { id :: Maybe Text

@@ -1,68 +0,0 @@--- | Parsing of unix timestamps-module Calamity.Types.UnixTimestamp (-    UnixTimestamp (..),-    unixToMilliseconds,-    millisecondsToUnix,-) where--import Calamity.Internal.Utils ()--import Control.Arrow--import Data.Aeson-import Data.Aeson.Encoding (word64)-import Data.Time-import Data.Time.Clock.POSIX-import Data.Word--import GHC.Generics--import Control.DeepSeq (NFData)-import TextShow-import qualified TextShow.Generic as TSG--newtype UnixTimestamp = UnixTimestamp-    { unUnixTimestamp :: UTCTime-    }-    deriving (Show, Eq, Generic)-    deriving newtype (NFData)-    deriving (TextShow) via TSG.FromGeneric UnixTimestamp--unixToMilliseconds :: UnixTimestamp -> Word64-unixToMilliseconds =-    unUnixTimestamp-        >>> utcTimeToPOSIXSeconds-        >>> toRational-        >>> (* 1000)-        >>> round--millisecondsToUnix :: Word64 -> UnixTimestamp-millisecondsToUnix =-    toRational-        >>> fromRational-        >>> (/ 1000)-        >>> posixSecondsToUTCTime-        >>> UnixTimestamp--instance ToJSON UnixTimestamp where-    toJSON =-        unUnixTimestamp-            >>> utcTimeToPOSIXSeconds-            >>> toRational-            >>> round-            >>> toJSON @Word64-    toEncoding =-        unUnixTimestamp-            >>> utcTimeToPOSIXSeconds-            >>> toRational-            >>> round-            >>> word64--instance FromJSON UnixTimestamp where-    parseJSON =-        withScientific "UnixTimestamp" $-            toRational-                >>> fromRational-                >>> posixSecondsToUTCTime-                >>> UnixTimestamp-                >>> pure

@@ -1,9 +1,17 @@ # Changelog for Calamity +## 0.1.30.2+++ Removed all the orphan instances from the library.++ Removed the export of `CalamityCommands.Handler` from `Calamity.Commands`.++ Added the export of `Calamity.Commands.Types` from `Calamity.Commands`.++ Fixed some parameter parser instances causing type inference to fail+  ([#48](https://github.com/simmsb/calamity/pull/48)).+ ## 0.1.30.1  + Removed the re-export of `CalamityCommands.ParsePrefix` from Calamity.Commands.-+ Added the `Calamity.Commands.Utils.useConstantPrefix` method++ Added the `Calamity.Commands.Utils.useConstantPrefix` method.  ## 0.1.30.0 

@@ -56,7 +56,7 @@ {- cabal:   build-depends:      base >= 4.13 && < 5-     , calamity >= 0.1.30+     , calamity >= 0.1.30.1      , text >= 1.2 && < 2      , lens >= 4.18 && < 5      , di-polysemy ^>= 0.2@@ -82,6 +82,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-}++{-# LANGUAGE BlockArguments #-}  {-# LANGUAGE TypeOperators #-} 

@@ -3,11 +3,9 @@ -- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack------ hash: 5d6785177c7a779a3dd4d3fe63a45997bd3697961f2756675e389b2da37cb817  name:           calamity-version:        0.1.30.1+version:        0.1.30.2 synopsis:       A library for writing discord bots in haskell description:    Please see the README on GitHub at <https://github.com/simmsb/calamity#readme> category:       Network, Web@@ -18,9 +16,9 @@ copyright:      2020 Ben Simms license:        MIT license-file:   LICENSE+build-type:     Simple tested-with:     GHC == 8.10.4-build-type:     Simple extra-source-files:     README.md     ChangeLog.md@@ -71,8 +69,11 @@       Calamity.Internal.ConstructorName       Calamity.Internal.IntColour       Calamity.Internal.LocalWriter+      Calamity.Internal.OverriddenVia       Calamity.Internal.RunIntoIO+      Calamity.Internal.ShapeCoerce       Calamity.Internal.SnowflakeMap+      Calamity.Internal.UnixTimestamp       Calamity.Internal.Updateable       Calamity.Internal.Utils       Calamity.Metrics.Eff@@ -117,7 +118,6 @@       Calamity.Types.Snowflake       Calamity.Types.Tellable       Calamity.Types.Token-      Calamity.Types.UnixTimestamp       Calamity.Types.Upgradeable       Calamity.Utils       Calamity.Utils.Colour@@ -177,9 +177,11 @@       TypeOperators       TypeApplications       RoleAnnotations+      QuasiQuotes   ghc-options: -fplugin=Polysemy.Plugin -funbox-strict-fields -Wall -fno-warn-name-shadowing   build-depends:-      aeson >=1.4 && <2+      PyF >=0.9.0.2 && <0.10+    , aeson >=1.4 && <2     , async >=2.2 && <3     , base >=4.13 && <5     , bytestring >=0.10 && <0.12@@ -196,7 +198,6 @@     , di-core >=1.0.4 && <1.1     , di-polysemy ==0.2.*     , exceptions ==0.10.*-    , fmt ==0.6.*     , focus >=1.0 && <2     , generic-lens >=2.0 && <3     , hashable >=1.2 && <2