calamity 0.1.9.4 → 0.1.10

raw patch · 12 files changed

+177/−37 lines, 12 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• README.md +2/−2
• calamity.cabal +3/−2
• src/Calamity/Cache/Eff.hs +3/−0
• src/Calamity/Cache/InMemory.hs +12/−4
• src/Calamity/Commands/CommandUtils.hs +1/−1
• src/Calamity/Commands/Dsl.hs +1/−1
• src/Calamity/Commands/Parser.hs +37/−13
• src/Calamity/HTTP/Internal/Request.hs +0/−3
• src/Calamity/Internal/BoundedStore.hs +11/−10
• src/Calamity/Types.hs +6/−1
• src/Calamity/Types/Upgradeable.hs +93/−0

@@ -1,5 +1,13 @@ # Changelog for Calamity +## 0.1.10.0++* Renamed `Calamity.Commands.Parser.KleeneConcat` to+  `Calamity.Commands.Parser.KleeneStarConcat` and added+  `Calamity.Commands.Parser.KleenePlusConcat`+  +* Added `Calamity.Types.Upgradeable`+ ## 0.1.9.2  *2020-05-23*

@@ -107,7 +107,7 @@ main :: IO () main = do   token <- view packed <$> getEnv "BOT_TOKEN"-  void . P.runFinal . P.embedToFinal . runCounterAtomic . runCacheInMemory . runMetricsPrometheusIO . useConstantPrefix "!"+  void . P.runFinal . P.embedToFinal . runCounterAtomic . runCacheInMemory . runMetricsNoop . useConstantPrefix "!"     $ runBotIO (BotToken token) $ do     addCommands $ do       helpCommand@@ -126,7 +126,7 @@           val <- getCounter           void $ tellt ctx ("The value is: " <> showtl val)         group "say" $ do-          command @'[KleeneConcat L.Text] "this" $ \ctx msg -> do+          command @'[KleenePlusConcat L.Text] "this" $ \ctx msg -> do             void $ tellt ctx msg       command @'[Snowflake Emoji] "etest" $ \ctx e -> do         void $ tellt ctx $ "got emoji: " <> showtl e

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: d09b5d61b03cb493c415218e661c595c070b5c50807b090c8689f0cbe15a9782+-- hash: 386f342de92acd940a2fa9856b8efa38f04e137426a3c6100bcbeaadb5ac5e17  name:           calamity-version:        0.1.9.4+version:        0.1.10 synopsis:       A library for writing discord bots description:    Please see the README on GitHub at <https://github.com/nitros12/calamity#readme> category:       Network, Web@@ -121,6 +121,7 @@       Calamity.Types.Tellable       Calamity.Types.Token       Calamity.Types.UnixTimestamp+      Calamity.Types.Upgradeable   other-modules:       Paths_calamity   hs-source-dirs:

@@ -9,6 +9,7 @@     , setGuild     , updateGuild     , getGuild+    , getGuildChannel     , getGuilds     , delGuild     , setDM@@ -53,6 +54,8 @@   SetGuild :: Guild -> CacheEff m ()   -- | Get a 'Guild' from the cache   GetGuild :: Snowflake Guild -> CacheEff m (Maybe Guild)+  -- | Get a 'GuildChannel' from the cache+  GetGuildChannel :: Snowflake GuildChannel -> CacheEff m (Maybe GuildChannel)   -- | Get all 'Guild's from the cache   GetGuilds :: CacheEff m [Guild]   -- | Delete a 'Guild' from the cache

@@ -14,6 +14,8 @@ import           Control.Lens import           Control.Monad.State.Strict +import qualified Data.HashMap.Lazy as LH+ import           Data.Default.Class import           Data.Foldable import qualified Data.HashSet                   as LS@@ -28,7 +30,7 @@   { user              :: Maybe User   , guilds            :: SM.SnowflakeMap Guild   , dms               :: SM.SnowflakeMap DMChannel-  , channels          :: SM.SnowflakeMap GuildChannel+  , guildChannels     :: LH.HashMap (Snowflake GuildChannel) Guild   , users             :: SM.SnowflakeMap User   , unavailableGuilds :: LS.HashSet (Snowflake Guild)   , messages          :: BoundedStore Message@@ -36,7 +38,7 @@   deriving ( Generic, Show )  emptyCache :: Cache-emptyCache = Cache Nothing SM.empty SM.empty SM.empty SM.empty LS.empty def+emptyCache = Cache Nothing SM.empty SM.empty LH.empty SM.empty LS.empty def  runCacheInMemory :: P.Member (P.Embed IO) r => P.Sem (CacheEff ': r) a -> P.Sem r a runCacheInMemory m = do@@ -51,10 +53,16 @@ runCache (SetBotUser u) = #user ?= u runCache GetBotUser     = use #user -runCache (SetGuild g)   = #guilds %= SM.insert g+runCache (SetGuild g)   = do+  #guilds %= SM.insert g+  #guildChannels %= LH.filter (\v -> getID @Guild v /= getID @Guild g)+  #guildChannels %= LH.union (LH.fromList $ map (,g) (SM.keys (g ^. #channels))) runCache (GetGuild gid) = use (#guilds . at gid)+runCache (GetGuildChannel cid) = use (#guildChannels . at cid) <&> (>>= (^. #channels . at cid)) runCache GetGuilds      = SM.elems <$> use #guilds-runCache (DelGuild gid) = #guilds %= sans gid+runCache (DelGuild gid) = do+  #guilds %= sans gid+  #guildChannels %= LH.filter (\v -> getID @Guild v /= gid)  runCache (SetDM dm)  = #dms %= SM.insert dm runCache (GetDM did) = use (#dms . at did)

@@ -69,7 +69,7 @@ -- Building a command that bans a user by id. -- -- @--- 'buildCommand' @\'['Named' "user" ('Snowflake' 'User'), 'Named' "reason" ('KleeneConcat' 'S.Text')]+-- 'buildCommand' @\'['Named' "user" ('Snowflake' 'User'), 'Named' "reason" ('KleeneStarConcat' 'S.Text')] --    "ban" 'Nothing' [] ('const' "Ban a user") $ \ctx uid r -> case (ctx 'Control.Lens.^.' #guild) of --      'Just' guild -> do --        'void' . 'Calamity.HTTP.invoke' . 'Calamity.HTTP.reason' r $ 'Calamity.HTTP.Guild.CreateGuildBan' guild uid

@@ -73,7 +73,7 @@ -- -- @ -- 'command' \@\'['Calamity.Commands.Parser.Named' "user" ('Calamity.Types.Snowflake' 'Calamity.Types.Model.User'),---                'Calamity.Commands.Parser.Named' "reason" ('Calamity.Commands.Parser.KleeneConcat' 'S.Text')]+--                'Calamity.Commands.Parser.Named' "reason" ('Calamity.Commands.Parser.KleeneStarConcat' 'S.Text')] --    "ban" $ \ctx uid r -> case (ctx 'Control.Lens.^.' #guild) of --      'Just' guild -> do --        'Control.Monad.void' . 'Calamity.HTTP.invoke' . 'Calamity.HTTP.reason' r $ 'Calamity.HTTP.Guild.CreateGuildBan' guild uid

@@ -2,7 +2,8 @@ module Calamity.Commands.Parser     ( Parser(..)     , Named-    , KleeneConcat+    , KleeneStarConcat+    , KleenePlusConcat     , runCommandParser ) where  import           Calamity.Cache.Eff@@ -19,6 +20,7 @@ import           Data.Char                     ( isSpace ) import           Data.Kind import           Data.List.NonEmpty            ( NonEmpty(..) )+import           Data.Semigroup import qualified Data.Text                     as S import qualified Data.Text.Lazy                as L import           Data.Typeable@@ -118,26 +120,48 @@  -- | A parser that consumes zero or more of @a@ then concatenates them together. ----- @'KleeneConcat' 'L.Text'@ Is therefore consumes all remaining input.-data KleeneConcat (a :: Type)+-- @'KleeneStarConcat' 'L.Text'@ Is therefore consumes all remaining input.+data KleeneStarConcat (a :: Type) -instance (Monoid (ParserResult a), Parser a r) => Parser (KleeneConcat a) r where-  type ParserResult (KleeneConcat a) = ParserResult a+instance (Monoid (ParserResult a), Parser a r) => Parser (KleeneStarConcat a) r where+  type ParserResult (KleeneStarConcat a) = ParserResult a    parse = mconcat <$> parse @[a] -instance {-# OVERLAPS #-}Parser (KleeneConcat L.Text) r where-  type ParserResult (KleeneConcat L.Text) = ParserResult L.Text+instance {-# OVERLAPS #-}Parser (KleeneStarConcat L.Text) r where+  type ParserResult (KleeneStarConcat L.Text) = ParserResult L.Text    -- consume rest on text just takes everything remaining-  parse = parseMP (parserName @(KleeneConcat L.Text)) someSingle+  parse = parseMP (parserName @(KleeneStarConcat L.Text)) manySingle -instance {-# OVERLAPS #-}Parser (KleeneConcat S.Text) r where-  type ParserResult (KleeneConcat S.Text) = ParserResult S.Text+instance {-# OVERLAPS #-}Parser (KleeneStarConcat S.Text) r where+  type ParserResult (KleeneStarConcat S.Text) = ParserResult S.Text    -- consume rest on text just takes everything remaining-  parse = parseMP (parserName @(KleeneConcat S.Text)) (L.toStrict <$> someSingle)+  parse = parseMP (parserName @(KleeneStarConcat S.Text)) (L.toStrict <$> manySingle) +-- | A parser that consumes one or more of @a@ then concatenates them together.+--+-- @'KleenePlusConcat' 'L.Text'@ Is therefore consumes all remaining input.+data KleenePlusConcat (a :: Type)++instance (Monoid (ParserResult a), Parser a r) => Parser (KleenePlusConcat a) r where+  type ParserResult (KleenePlusConcat a) = ParserResult a++  parse = sconcat <$> parse @(NonEmpty a)++instance {-# OVERLAPS #-}Parser (KleenePlusConcat L.Text) r where+  type ParserResult (KleenePlusConcat L.Text) = ParserResult L.Text++  -- consume rest on text just takes everything remaining+  parse = parseMP (parserName @(KleenePlusConcat L.Text)) someSingle++instance {-# OVERLAPS #-}Parser (KleenePlusConcat S.Text) r where+  type ParserResult (KleenePlusConcat S.Text) = ParserResult S.Text++  -- consume rest on text just takes everything remaining+  parse = parseMP (parserName @(KleenePlusConcat S.Text)) (L.toStrict <$> someSingle)+ instance Typeable (Snowflake a) => Parser (Snowflake a) r where   parse = parseMP (parserName @(Snowflake a)) snowflake @@ -226,8 +250,8 @@ item :: MonadParsec e L.Text m => m L.Text item = try quotedString <|> someNonWS --- manySingle :: MonadParsec e s m => m (Tokens s)--- manySingle = takeWhileP (Just "Any character") (const True)+manySingle :: MonadParsec e s m => m (Tokens s)+manySingle = takeWhileP (Just "Any character") (const True)  someSingle :: MonadParsec e s m => m (Tokens s) someSingle = takeWhile1P (Just "any character") (const True)

@@ -15,7 +15,6 @@ import           Calamity.HTTP.Internal.Ratelimit import           Calamity.HTTP.Internal.Route import           Calamity.HTTP.Internal.Types-import           Calamity.Internal.Utils import           Calamity.Metrics.Eff import           Calamity.Types.Token @@ -38,8 +37,6 @@ import qualified Polysemy                         as P import qualified Polysemy.Error                   as P import qualified Polysemy.Reader                  as P--import           TextShow  fromResult :: P.Member (P.Error RestError) r => Data.Aeson.Result a -> Sem r a fromResult (Success a) = pure a

@@ -12,20 +12,20 @@ import           Control.Monad.State.Lazy  import           Data.Default.Class-import           Data.Generics.Labels                 ()-import           Data.HashMap.Lazy                    ( HashMap )-import qualified Data.HashMap.Lazy                    as H+import           Data.Generics.Labels     ()+import           Data.HashMap.Lazy        ( HashMap )+import qualified Data.HashMap.Lazy        as H -import qualified Deque.Lazy                           as DQ-import           Deque.Lazy                           ( Deque )+import qualified Deque.Lazy               as DQ+import           Deque.Lazy               ( Deque )  import           GHC.Generics  data BoundedStore a = BoundedStore   { itemQueue :: Deque (Snowflake a)   , items     :: HashMap (Snowflake a) a-  , limit        :: Int-  , size         :: Int+  , limit     :: Int+  , size      :: Int   }   deriving ( Show, Generic ) @@ -36,6 +36,7 @@   def = BoundedStore mempty H.empty 1000 0  type instance (Index (BoundedStore a)) = Snowflake a+ type instance (IxValue (BoundedStore a)) = a  instance HasID' a => Ixed (BoundedStore a)@@ -51,14 +52,14 @@  addItem :: HasID' a => a -> BoundedStore a -> BoundedStore a addItem m = execState $ do-  unlessM (H.member (getID m) <$> use #items) do+  unlessM (H.member (getID m) <$> use #items) $ do     #itemQueue %= DQ.cons (getID m)     #size += 1    size <- use #size   limit <- use #limit -  when (size > limit) do+  when (size > limit) $ do     q <- use #itemQueue     let Just (rid, q') = DQ.unsnoc q     #itemQueue .= q'@@ -76,7 +77,7 @@  dropItem :: Snowflake a -> BoundedStore a -> BoundedStore a dropItem id = execState $ do-  whenM (H.member id <$> use #items) do+  whenM (H.member id <$> use #items) $ do     #size -= 1    #itemQueue %= DQ.filter (/= id)

@@ -5,6 +5,7 @@     , module Calamity.Types.Snowflake     , module Calamity.Types.Token     , module Calamity.Types.Tellable+    , module Calamity.Types.Upgradeable     , module Calamity.Types.UnixTimestamp     -- * Types     -- $typesDocs@@ -15,11 +16,15 @@ import           Calamity.Types.Snowflake import           Calamity.Types.Token import           Calamity.Types.Tellable+import           Calamity.Types.Upgradeable import           Calamity.Types.UnixTimestamp  -- $typesDocs -- -- This module collects all discord models, and other useful types together. ----- The 'Tellable' class is also in here, which allows you to construct and send+-- The 'Tellable' class allows you to construct and send -- messages to things to you can send messages to in a neat way.+--+-- The 'Upgradeable' class allows you to upgrade a snowflake to the full value+-- it refers to.

@@ -0,0 +1,93 @@+-- | Things that can be upgraded from snowflakes to their full data+module Calamity.Types.Upgradeable+    ( Upgradeable(..) ) where++import           Calamity.Cache.Eff+import           Calamity.Client.Types+import           Calamity.HTTP                  as H+import           Calamity.Internal.Utils+import           Calamity.Types.Model.Channel+import           Calamity.Types.Model.Guild+import           Calamity.Types.Model.User+import           Calamity.Types.Snowflake++import           Control.Applicative+import           Control.Lens++import           Data.Generics.Sum.Constructors++import qualified Polysemy                       as P+import qualified Polysemy.Fail                  as P+import qualified Polysemy.NonDet                as P++class Upgradeable a ids | a -> ids, ids -> a where+  upgrade :: BotC r => ids -> P.Sem r (Maybe a)++maybeToAlt :: Alternative f => Maybe a -> f a+maybeToAlt (Just x) = pure x+maybeToAlt Nothing = empty++instance Upgradeable User (Snowflake User) where+  upgrade uid = P.runNonDetMaybe ((getUser uid >>= maybeToAlt) <|> gethttp)+    where+      gethttp = P.failToNonDet $ do+        Right u <- invoke $ H.GetUser uid+        setUser u+        pure u++instance Upgradeable Member (Snowflake Guild, Snowflake Member) where+  upgrade (gid, mid) = P.runNonDetMaybe (getcache <|> gethttp)+    where+      getcache = P.failToNonDet $ do+        Just g <- getGuild gid+        Just m <- pure (g ^. #members . at mid)+        pure m+      gethttp = P.failToNonDet $ do+        Right m <- invoke $ H.GetGuildMember gid (coerceSnowflake @_ @User mid)+        -- getcache could have failed becuase the member wasn't cached+        updateGuild gid (#members . at mid ?~ m)+        pure m++instance Upgradeable Guild (Snowflake Guild) where+  upgrade gid = P.runNonDetMaybe ((getGuild gid >>= maybeToAlt) <|> gethttp)+    where+      gethttp = P.failToNonDet $ do+        Right g <- invoke $ H.GetGuild gid+        pure g++insertChannel :: BotC r => Channel -> P.Sem r ()+insertChannel (DMChannel' dm) = setDM dm+insertChannel (GuildChannel' ch) =+  updateGuild (getID ch) (#channels . at (getID @GuildChannel ch) ?~ ch)+insertChannel _ = pure ()++instance Upgradeable Channel (Snowflake Channel) where+  upgrade cid = P.runNonDetMaybe (getcacheDM <|> getcacheGuild <|> gethttp)+    where+      getcacheDM = DMChannel' <<$>> getDM (coerceSnowflake cid) >>= maybeToAlt+      getcacheGuild = GuildChannel' <<$>> getGuildChannel (coerceSnowflake cid) >>= maybeToAlt+      gethttp = P.failToNonDet $ do+        Right c <- invoke $ H.GetChannel cid+        insertChannel c+        pure c++instance Upgradeable GuildChannel (Snowflake GuildChannel) where+  upgrade cid = P.runNonDetMaybe (getcache <|> gethttp)+    where+      getcache = getGuildChannel (coerceSnowflake cid) >>= maybeToAlt+      gethttp = P.failToNonDet $ do+        Right c <- invoke $ H.GetChannel (coerceSnowflake @_ @Channel cid)+        insertChannel c+        maybeToAlt (c ^? _Ctor @"GuildChannel'")++instance Upgradeable Emoji (Snowflake Guild, Snowflake Emoji) where+  upgrade (gid, eid) = P.runNonDetMaybe (getcache <|> gethttp)+    where+      getcache = P.failToNonDet $ do+        Just g <- getGuild gid+        Just m <- pure (g ^. #emojis . at eid)+        pure m+      gethttp = P.failToNonDet $ do+        Right e <- invoke $ H.GetGuildEmoji gid eid+        updateGuild gid (#emojis . at eid ?~ e)+        pure e