calamity 0.1.14.0 → 0.1.14.1

raw patch · 9 files changed

+57/−92 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• calamity.cabal +2/−2
• src/Calamity/Gateway/DispatchEvents.hs +1/−1
• src/Calamity/Internal/AesonThings.hs +43/−84
• src/Calamity/Types/Model/Channel/Message.hs +1/−1
• src/Calamity/Types/Model/Channel/UpdatedMessage.hs +1/−1
• src/Calamity/Types/Model/Channel/Webhook.hs +1/−1
• src/Calamity/Types/Model/Guild/Emoji.hs +1/−1
• src/Calamity/Types/Model/Guild/Invite.hs +1/−1

@@ -1,5 +1,11 @@ # Changelog for Calamity +## 0.1.14.1++*2020-06-08*++* Fix broken json decoding for member's+ ## 0.1.14.0  *2020-06-08*

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: d770f5d135638e3a804e22c7d2f45e4b065401028478fe7cff6ccc542244ca35+-- hash: 17e82ecf5c56e8f6cd338935a102965df59d7bdfffee1d9c0461ac66c9089a7c  name:           calamity-version:        0.1.14.0+version:        0.1.14.1 synopsis:       A library for writing discord bots description:    Please see the README on GitHub at <https://github.com/nitros12/calamity#readme> category:       Network, Web

@@ -164,7 +164,7 @@   }   deriving ( Show, Generic )   deriving ( FromJSON ) via WithSpecialCases-      '["inviter" `ExtractField` "id", "targetUser" `ExtractField` "id"]+      '["inviter" `ExtractFieldFrom` "id", "targetUser" `ExtractFieldFrom` "id"]       InviteCreateData  data InviteDeleteData = InviteDeleteData

@@ -1,12 +1,10 @@ module Calamity.Internal.AesonThings-    ( WithSpecialCases-    , WithSpecialCasesInner(..)-    , type IfNoneThen-    , type ExtractField-    , type ExtractFields-    , type ExtractArrayField-    , type InjectID-    , SpecialRule+    ( WithSpecialCases(..)+    , IfNoneThen+    , ExtractFieldFrom+    , ExtractFieldInto+    , ExtractFields+    , ExtractArrayField     , DefaultToEmptyArray     , DefaultToZero     , DefaultToFalse@@ -26,103 +24,64 @@ import           Data.Typeable  import           GHC.Generics-import qualified GHC.TypeLits          as TL-import           GHC.TypeLits          ( KnownSymbol, Symbol, symbolVal )-import Control.Monad ((>=>))--textSymbolVal :: forall n. KnownSymbol n => Proxy n -> Text-textSymbolVal _ = symbolVal @n Proxy ^. packed--data SpecialCaseList-  = SpecialCaseNil-  | forall label action inner. SpecialCaseElem label action inner--data SpecialRule (label :: Symbol) (action :: SpecialRuleAction)--data SpecialRuleAction-  = forall d. IfNoneThen d-  | forall field. ExtractField field-  | forall fields. ExtractFields fields-  | forall field. ExtractArrayField field-  | forall mn idn. InjectID idn mn--type IfNoneThen label d =-  SpecialRule label ('IfNoneThen d)--type ExtractField label field =-  SpecialRule label ('ExtractField field)--type ExtractFields label fields =-  SpecialRule label ('ExtractFields fields)+import           GHC.TypeLits          ( KnownSymbol, symbolVal )+import           Control.Monad ((>=>)) -type ExtractArrayField label field =-  SpecialRule label ('ExtractArrayField field)+textSymbolVal :: forall n. KnownSymbol n => Text+textSymbolVal = symbolVal @n Proxy ^. packed -type InjectID label mn idn =-  SpecialRule label ('InjectID mn idn)+data IfNoneThen label def+data ExtractFieldInto label field target+type ExtractFieldFrom label field = ExtractFieldInto label field label+data ExtractFields label fields+data ExtractArrayField label field -class PerformAction (action :: SpecialRuleAction) where-  runAction :: Proxy action -> Value -> Parser Value+class PerformAction action where+  runAction :: Proxy action -> Object -> Parser Object -instance Reifies d Value => PerformAction ('IfNoneThen d) where-  runAction _ Null = pure $ reflect @d Proxy-  runAction _ x = pure x+instance (Reifies d Value, KnownSymbol label) => PerformAction (IfNoneThen label d) where+  runAction _ o = do+    v <- o .:? textSymbolVal @label .!= reflect @d Proxy+    pure $ o & at (textSymbolVal @label) ?~ v -instance (KnownSymbol field) => PerformAction ('ExtractField field) where-  runAction _ Null = pure Null-  runAction _ o = withObject (("extracting field " <> textSymbolVal @field Proxy) ^. unpacked)-    (.: textSymbolVal @field Proxy) o+instance (KnownSymbol label, KnownSymbol field, KnownSymbol target) => PerformAction (ExtractFieldInto label field target) where+  runAction _ o =+    let v :: Maybe Value = o ^? ix (textSymbolVal @label) . _Object . ix (textSymbolVal @field)+    in pure $ o & at (textSymbolVal @target) .~ v -instance PerformAction ('ExtractFields '[]) where+instance PerformAction (ExtractFields label '[]) where   runAction _ = pure -instance (KnownSymbol field, PerformAction ('ExtractFields fields)) => PerformAction ('ExtractFields (field : fields)) where-  runAction _ = runAction (Proxy @('ExtractField field)) >=> runAction (Proxy @('ExtractFields fields))--instance KnownSymbol field => PerformAction ('ExtractArrayField field) where-  runAction _ Null = pure Null-  runAction _ o = withArray (("extracting fields " <> textSymbolVal @field Proxy) ^. unpacked)-    ((Array <$>) . traverse (withObject "extracting field" (.: textSymbolVal @field Proxy))) o--instance (KnownSymbol idn, KnownSymbol mn) => PerformAction ('InjectID idn mn) where-  runAction _ = withObject-    (("injecting id from " <> textSymbolVal @idn Proxy <> " into " <> textSymbolVal @mn Proxy) ^. unpacked) $ \o -> do-      id <- o .: "id"--      pure (Object o-            & key (textSymbolVal @mn Proxy) . values . _Object . at (textSymbolVal @idn Proxy) ?~ id)--type family FoldSpecialCases (rules :: [Type]) :: SpecialCaseList where-  FoldSpecialCases '[]                              = 'SpecialCaseNil-  FoldSpecialCases (SpecialRule label action ': xs) = 'SpecialCaseElem label action (FoldSpecialCases xs)-  FoldSpecialCases _ = TL.TypeError ('TL.Text "What did you do?")+instance (KnownSymbol field,+          PerformAction (ExtractFieldInto label field field),+          PerformAction (ExtractFields label fields)) =>+         PerformAction (ExtractFields label (field : fields)) where+  runAction _ = runAction (Proxy @(ExtractFieldInto label field field)) >=> runAction (Proxy @(ExtractFields label fields)) -newtype WithSpecialCasesInner (rules :: SpecialCaseList) a = WithSpecialCasesInner-  { unwrapWithSpecialCases :: a-  }+instance (KnownSymbol label, KnownSymbol field) => PerformAction (ExtractArrayField label field) where+  runAction _ o = do+    a :: Array <- o .: textSymbolVal @label+    a' <- Array <$> traverse (withObject "extracting field" (.: textSymbolVal @field)) a+    pure $ o & at (textSymbolVal @label) ?~ a' -type family WithSpecialCases rules a :: Type where-  WithSpecialCases rules a = WithSpecialCasesInner (FoldSpecialCases rules) a+newtype WithSpecialCases (rules :: [Type]) a = WithSpecialCases a  class RunSpecialCase a where   runSpecialCases :: Proxy a -> Object -> Parser Object -instance RunSpecialCase 'SpecialCaseNil where+instance RunSpecialCase '[] where   runSpecialCases _ = pure . id -instance (RunSpecialCase inner, KnownSymbol label, PerformAction action)-  => RunSpecialCase ('SpecialCaseElem label action inner) where+instance (RunSpecialCase xs, PerformAction action) => RunSpecialCase (action : xs) where   runSpecialCases _ o = do-    o' <- runSpecialCases (Proxy @inner) o-    v <- o' .:? textSymbolVal @label Proxy .!= Null-    v' <- runAction (Proxy @action) v-    pure (o' & at (textSymbolVal @label Proxy) ?~ v')+    o' <- runSpecialCases (Proxy @xs) o+    runAction (Proxy @action) o'  instance (RunSpecialCase rules, Typeable a, Generic a, GFromJSON Zero (Rep a))-  => FromJSON (WithSpecialCasesInner rules a) where+  => FromJSON (WithSpecialCases rules a) where   parseJSON = withObject (show . typeRep $ Proxy @a) $ \o -> do     o' <- runSpecialCases (Proxy @rules) o-    WithSpecialCasesInner <$> genericParseJSON jsonOptions (Object o')+    WithSpecialCases <$> genericParseJSON jsonOptions (Object o')   data DefaultToEmptyArray

@@ -47,7 +47,7 @@   deriving ( TextShow ) via TSG.FromGeneric Message   deriving ( ToJSON ) via CalamityJSON Message   deriving ( FromJSON ) via WithSpecialCases-      '["author" `ExtractField` "id", "mentions" `ExtractArrayField` "id",+      '["author" `ExtractFieldFrom` "id", "mentions" `ExtractArrayField` "id",         "reactions" `IfNoneThen` DefaultToEmptyArray]       Message   deriving ( HasID Message ) via HasIDField "id" Message

@@ -37,7 +37,7 @@   deriving ( Eq, Show, Generic )   deriving ( TextShow ) via TSG.FromGeneric UpdatedMessage   deriving ( FromJSON ) via WithSpecialCases-      '["author" `ExtractField` "id", "mentions" `ExtractArrayField` "id"]+      '["author" `ExtractFieldFrom` "id", "mentions" `ExtractArrayField` "id"]       UpdatedMessage   deriving ( HasID Message ) via HasIDField "id" UpdatedMessage   deriving ( HasID Channel ) via HasIDField "channelID" UpdatedMessage

@@ -28,5 +28,5 @@   }   deriving ( Eq, Show, Generic )   deriving ( TextShow ) via TSG.FromGeneric Webhook-  deriving ( FromJSON ) via WithSpecialCases '["user" `ExtractField` "id"] Webhook+  deriving ( FromJSON ) via WithSpecialCases '["user" `ExtractFieldFrom` "id"] Webhook   deriving ( HasID Webhook ) via HasIDField "id" Webhook

@@ -31,7 +31,7 @@   deriving ( Eq, Show, Generic )   deriving ( TextShow ) via TSG.FromGeneric Emoji   deriving ( ToJSON ) via CalamityJSON Emoji-  deriving ( FromJSON ) via WithSpecialCases '["user" `ExtractField` "id"] Emoji+  deriving ( FromJSON ) via WithSpecialCases '["user" `ExtractFieldFrom` "id"] Emoji   deriving ( HasID Emoji ) via HasIDField "id" Emoji  data instance Partial Emoji = PartialEmoji

@@ -28,4 +28,4 @@   deriving ( Eq, Show, Generic )   deriving ( TextShow ) via TSG.FromGeneric Invite   deriving ( ToJSON ) via CalamityJSON Invite-  deriving ( FromJSON ) via WithSpecialCases '["targetUser" `ExtractField` "id"] Invite+  deriving ( FromJSON ) via WithSpecialCases '["targetUser" `ExtractFieldFrom` "id"] Invite