{-# LANGUAGE TemplateHaskell #-}
module Calamity.Client.Types (
Client (..),
StartupError (..),
EventType (..),
GuildCreateStatus (..),
GuildDeleteStatus (..),
EHType,
BotC,
SetupEff,
ReactConstraints,
EventHandlers (..),
InsertEventHandler (..),
RemoveEventHandler (..),
getEventHandlers,
getCustomEventHandlers,
) where
import Calamity.Cache.Eff
import Calamity.Gateway.DispatchEvents (CalamityEvent (..), InviteCreateData, InviteDeleteData, ReactionEvtData, ReadyData)
import Calamity.Gateway.Types (ControlMessage)
import Calamity.HTTP.Internal.Ratelimit
import Calamity.HTTP.Internal.Types
import Calamity.Metrics.Eff
import Calamity.Types.LogEff
import Calamity.Types.Model.Channel
import Calamity.Types.Model.Channel.UpdatedMessage
import Calamity.Types.Model.Guild
import Calamity.Types.Model.Interaction (Interaction)
import Calamity.Types.Model.User
import Calamity.Types.Model.Voice
import Calamity.Types.Snowflake
import Calamity.Types.Token
import Calamity.Types.TokenEff
import Control.Concurrent.Async
import Control.Concurrent.Chan.Unagi
import Control.Concurrent.MVar
import Control.Concurrent.STM.TVar
import Data.Default.Class
import Data.Dynamic
import Data.IORef
import Data.Kind (Type)
import Data.Maybe
import Data.Time
import Data.TypeRepMap (TypeRepMap, WrapTypeable (..))
import qualified Data.TypeRepMap as TM
import Data.Typeable
import Data.Void (Void)
import qualified Df1
import qualified Di.Core as DC
import GHC.Exts (fromList)
import Optics.TH
import qualified Polysemy as P
import qualified Polysemy.Async as P
import qualified Polysemy.AtomicState as P
import qualified Polysemy.Reader as P
data Client = Client
{ Client -> TVar [(InChan ControlMessage, Async (Maybe ()))]
shards :: TVar [(InChan ControlMessage, Async (Maybe ()))]
, Client -> MVar Int
numShards :: MVar Int
, Client -> Token
token :: Token
, Client -> RateLimitState
rlState :: RateLimitState
, Client -> InChan CalamityEvent
eventsIn :: InChan CalamityEvent
, Client -> OutChan CalamityEvent
eventsOut :: OutChan CalamityEvent
, Client -> IORef Integer
ehidCounter :: IORef Integer
, Client -> Maybe (Di Level Path Message)
initialDi :: Maybe (DC.Di Df1.Level Df1.Path Df1.Message)
}
type BotC r =
( P.Members
'[ LogEff
, MetricEff
, CacheEff
, RatelimitEff
, TokenEff
, P.Reader Client
, P.AtomicState EventHandlers
, P.Embed IO
, P.Final IO
, P.Async
]
r
)
type SetupEff r = (RatelimitEff ': TokenEff ': P.Reader Client ': P.AtomicState EventHandlers ': P.Async ': r)
type ReactConstraints s =
( InsertEventHandler s
, RemoveEventHandler s
)
newtype StartupError = StartupError String
deriving stock (Int -> StartupError -> ShowS
[StartupError] -> ShowS
StartupError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StartupError] -> ShowS
$cshowList :: [StartupError] -> ShowS
show :: StartupError -> String
$cshow :: StartupError -> String
showsPrec :: Int -> StartupError -> ShowS
$cshowsPrec :: Int -> StartupError -> ShowS
Show)
data EventType
= ReadyEvt
| ChannelCreateEvt
| ChannelUpdateEvt
| ChannelDeleteEvt
| ChannelpinsUpdateEvt
| GuildCreateEvt
| GuildUpdateEvt
| GuildDeleteEvt
| GuildBanAddEvt
| GuildBanRemoveEvt
| GuildEmojisUpdateEvt
| GuildIntegrationsUpdateEvt
| GuildMemberAddEvt
| GuildMemberRemoveEvt
| GuildMemberUpdateEvt
| GuildMembersChunkEvt
| GuildRoleCreateEvt
| GuildRoleUpdateEvt
| GuildRoleDeleteEvt
| InviteCreateEvt
| InviteDeleteEvt
| MessageCreateEvt
|
MessageUpdateEvt
|
RawMessageUpdateEvt
|
MessageDeleteEvt
|
RawMessageDeleteEvt
|
MessageDeleteBulkEvt
|
RawMessageDeleteBulkEvt
|
MessageReactionAddEvt
|
RawMessageReactionAddEvt
|
MessageReactionRemoveEvt
|
RawMessageReactionRemoveEvt
|
MessageReactionRemoveAllEvt
|
RawMessageReactionRemoveAllEvt
| TypingStartEvt
| UserUpdateEvt
|
VoiceStateUpdateEvt
|
InteractionEvt
|
forall (a :: Type). CustomEvt a
data GuildCreateStatus
=
GuildCreateNew
|
GuildCreateAvailable
deriving (Int -> GuildCreateStatus -> ShowS
[GuildCreateStatus] -> ShowS
GuildCreateStatus -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GuildCreateStatus] -> ShowS
$cshowList :: [GuildCreateStatus] -> ShowS
show :: GuildCreateStatus -> String
$cshow :: GuildCreateStatus -> String
showsPrec :: Int -> GuildCreateStatus -> ShowS
$cshowsPrec :: Int -> GuildCreateStatus -> ShowS
Show)
data GuildDeleteStatus
=
GuildDeleteUnavailable
|
GuildDeleteRemoved
deriving (Int -> GuildDeleteStatus -> ShowS
[GuildDeleteStatus] -> ShowS
GuildDeleteStatus -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GuildDeleteStatus] -> ShowS
$cshowList :: [GuildDeleteStatus] -> ShowS
show :: GuildDeleteStatus -> String
$cshow :: GuildDeleteStatus -> String
showsPrec :: Int -> GuildDeleteStatus -> ShowS
$cshowsPrec :: Int -> GuildDeleteStatus -> ShowS
Show)
type family EHType (d :: EventType) where
EHType 'ReadyEvt = ReadyData
EHType 'ChannelCreateEvt = Channel
EHType 'ChannelUpdateEvt = (Channel, Channel)
EHType 'ChannelDeleteEvt = Channel
EHType 'ChannelpinsUpdateEvt = (Channel, Maybe UTCTime)
EHType 'GuildCreateEvt = (Guild, GuildCreateStatus)
EHType 'GuildUpdateEvt = (Guild, Guild)
EHType 'GuildDeleteEvt = (Guild, GuildDeleteStatus)
EHType 'GuildBanAddEvt = (Guild, User)
EHType 'GuildBanRemoveEvt = (Guild, User)
EHType 'GuildEmojisUpdateEvt = (Guild, [Emoji])
EHType 'GuildIntegrationsUpdateEvt = Guild
EHType 'GuildMemberAddEvt = (Guild, Member)
EHType 'GuildMemberRemoveEvt = (Guild, Member)
EHType 'GuildMemberUpdateEvt = (Guild, Member, Member)
EHType 'GuildMembersChunkEvt = (Guild, [Member])
EHType 'GuildRoleCreateEvt = (Guild, Role)
EHType 'GuildRoleUpdateEvt = (Guild, Role, Role)
EHType 'GuildRoleDeleteEvt = (Guild, Role)
EHType 'InviteCreateEvt = InviteCreateData
EHType 'InviteDeleteEvt = InviteDeleteData
EHType 'MessageCreateEvt = (Message, Maybe User, Maybe Member)
EHType 'MessageUpdateEvt = (Message, Message, Maybe User, Maybe Member)
EHType 'MessageDeleteEvt = Message
EHType 'MessageDeleteBulkEvt = [Message]
EHType 'MessageReactionAddEvt = (Message, User, Channel, RawEmoji)
EHType 'MessageReactionRemoveEvt = (Message, User, Channel, RawEmoji)
EHType 'MessageReactionRemoveAllEvt = Message
EHType 'RawMessageUpdateEvt = (UpdatedMessage, Maybe User, Maybe Member)
EHType 'RawMessageDeleteEvt = Snowflake Message
EHType 'RawMessageDeleteBulkEvt = [Snowflake Message]
EHType 'RawMessageReactionAddEvt = ReactionEvtData
EHType 'RawMessageReactionRemoveEvt = ReactionEvtData
EHType 'RawMessageReactionRemoveAllEvt = Snowflake Message
EHType 'TypingStartEvt = (Channel, Snowflake User, UTCTime)
EHType 'UserUpdateEvt = (User, User)
EHType 'VoiceStateUpdateEvt = (Maybe VoiceState, VoiceState)
EHType 'InteractionEvt = Interaction
EHType ( 'CustomEvt a) = a
type StoredEHType t = EHType t -> IO ()
newtype EventHandlers = EventHandlers (TypeRepMap EventHandler)
data EventHandlerWithID (a :: Type) = EventHandlerWithID
{ forall a. EventHandlerWithID a -> Integer
ehID :: Integer
, forall a. EventHandlerWithID a -> a
eh :: a
}
newtype CustomEHTypeStorage (a :: Type) = CustomEHTypeStorage
{ forall a.
CustomEHTypeStorage a -> [EventHandlerWithID (a -> IO ())]
unwrapCustomEHTypeStorage :: [EventHandlerWithID (a -> IO ())]
}
deriving newtype (CustomEHTypeStorage a
[CustomEHTypeStorage a] -> CustomEHTypeStorage a
CustomEHTypeStorage a
-> CustomEHTypeStorage a -> CustomEHTypeStorage a
forall {a}. Semigroup (CustomEHTypeStorage a)
forall a. CustomEHTypeStorage a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. [CustomEHTypeStorage a] -> CustomEHTypeStorage a
forall a.
CustomEHTypeStorage a
-> CustomEHTypeStorage a -> CustomEHTypeStorage a
mconcat :: [CustomEHTypeStorage a] -> CustomEHTypeStorage a
$cmconcat :: forall a. [CustomEHTypeStorage a] -> CustomEHTypeStorage a
mappend :: CustomEHTypeStorage a
-> CustomEHTypeStorage a -> CustomEHTypeStorage a
$cmappend :: forall a.
CustomEHTypeStorage a
-> CustomEHTypeStorage a -> CustomEHTypeStorage a
mempty :: CustomEHTypeStorage a
$cmempty :: forall a. CustomEHTypeStorage a
Monoid, NonEmpty (CustomEHTypeStorage a) -> CustomEHTypeStorage a
CustomEHTypeStorage a
-> CustomEHTypeStorage a -> CustomEHTypeStorage a
forall b.
Integral b =>
b -> CustomEHTypeStorage a -> CustomEHTypeStorage a
forall a. NonEmpty (CustomEHTypeStorage a) -> CustomEHTypeStorage a
forall a.
CustomEHTypeStorage a
-> CustomEHTypeStorage a -> CustomEHTypeStorage a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall a b.
Integral b =>
b -> CustomEHTypeStorage a -> CustomEHTypeStorage a
stimes :: forall b.
Integral b =>
b -> CustomEHTypeStorage a -> CustomEHTypeStorage a
$cstimes :: forall a b.
Integral b =>
b -> CustomEHTypeStorage a -> CustomEHTypeStorage a
sconcat :: NonEmpty (CustomEHTypeStorage a) -> CustomEHTypeStorage a
$csconcat :: forall a. NonEmpty (CustomEHTypeStorage a) -> CustomEHTypeStorage a
<> :: CustomEHTypeStorage a
-> CustomEHTypeStorage a -> CustomEHTypeStorage a
$c<> :: forall a.
CustomEHTypeStorage a
-> CustomEHTypeStorage a -> CustomEHTypeStorage a
Semigroup)
type family EHStorageType (t :: EventType) where
EHStorageType ( 'CustomEvt _) = TypeRepMap CustomEHTypeStorage
EHStorageType t = [EventHandlerWithID (StoredEHType t)]
newtype EventHandler (t :: EventType) = EH
{ forall (t :: EventType).
EventHandler t
-> (Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t
unwrapEventHandler :: (Semigroup (EHStorageType t), Monoid (EHStorageType t)) => EHStorageType t
}
instance Semigroup (EventHandler t) where
EH (Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t
a <> :: EventHandler t -> EventHandler t -> EventHandler t
<> EH (Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t
b = forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH forall a b. (a -> b) -> a -> b
$ (Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t
a forall a. Semigroup a => a -> a -> a
<> (Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t
b
instance Monoid (EventHandler t) where
mempty :: EventHandler t
mempty = forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH forall a. Monoid a => a
mempty
instance Default EventHandlers where
def :: EventHandlers
def =
TypeRepMap EventHandler -> EventHandlers
EventHandlers forall a b. (a -> b) -> a -> b
$
forall l. IsList l => [Item l] -> l
fromList
[ forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'ReadyEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'ChannelCreateEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'ChannelUpdateEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'ChannelDeleteEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'ChannelpinsUpdateEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'GuildCreateEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'GuildUpdateEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'GuildDeleteEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'GuildBanAddEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'GuildBanRemoveEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'GuildEmojisUpdateEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'GuildIntegrationsUpdateEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'GuildMemberAddEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'GuildMemberRemoveEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'GuildMemberUpdateEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'GuildMembersChunkEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'GuildRoleCreateEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'GuildRoleUpdateEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'GuildRoleDeleteEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'MessageCreateEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'MessageUpdateEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'MessageDeleteEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'MessageDeleteBulkEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'MessageReactionAddEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'MessageReactionRemoveEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'MessageReactionRemoveAllEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'TypingStartEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'UserUpdateEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @'InteractionEvt []
, forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> WrapTypeable f
WrapTypeable forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @( 'CustomEvt Void) forall {k} (f :: k -> *). TypeRepMap f
TM.empty
]
instance Semigroup EventHandlers where
(EventHandlers TypeRepMap EventHandler
a) <> :: EventHandlers -> EventHandlers -> EventHandlers
<> (EventHandlers TypeRepMap EventHandler
b) = TypeRepMap EventHandler -> EventHandlers
EventHandlers forall a b. (a -> b) -> a -> b
$ forall {k} (f :: k -> *).
(forall (x :: k). Typeable x => f x -> f x -> f x)
-> TypeRepMap f -> TypeRepMap f -> TypeRepMap f
TM.unionWith forall a. Semigroup a => a -> a -> a
(<>) TypeRepMap EventHandler
a TypeRepMap EventHandler
b
instance Monoid EventHandlers where
mempty :: EventHandlers
mempty = forall a. Default a => a
def
type family EHInstanceSelector (d :: EventType) :: Bool where
EHInstanceSelector ( 'CustomEvt _) = 'True
EHInstanceSelector _ = 'False
class InsertEventHandler (a :: EventType) where
makeEventHandlers :: Proxy a -> Integer -> StoredEHType a -> EventHandlers
instance (EHInstanceSelector a ~ flag, InsertEventHandler' flag a) => InsertEventHandler a where
makeEventHandlers :: Proxy a -> Integer -> StoredEHType a -> EventHandlers
makeEventHandlers = forall (flag :: Bool) (a :: EventType).
InsertEventHandler' flag a =>
Proxy flag -> Proxy a -> Integer -> StoredEHType a -> EventHandlers
makeEventHandlers' (forall {k} (t :: k). Proxy t
Proxy @flag)
class InsertEventHandler' (flag :: Bool) a where
makeEventHandlers' :: Proxy flag -> Proxy a -> Integer -> StoredEHType a -> EventHandlers
instance forall (x :: Type). (Typeable (EHType ( 'CustomEvt x))) => InsertEventHandler' 'True ( 'CustomEvt x) where
makeEventHandlers' :: Proxy 'True
-> Proxy ('CustomEvt x)
-> Integer
-> StoredEHType ('CustomEvt x)
-> EventHandlers
makeEventHandlers' Proxy 'True
_ Proxy ('CustomEvt x)
_ Integer
id' StoredEHType ('CustomEvt x)
handler =
TypeRepMap EventHandler -> EventHandlers
EventHandlers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> TypeRepMap f
TM.one forall a b. (a -> b) -> a -> b
$
forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @( 'CustomEvt Void)
(forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> TypeRepMap f
TM.one @x forall a b. (a -> b) -> a -> b
$ forall a.
[EventHandlerWithID (a -> IO ())] -> CustomEHTypeStorage a
CustomEHTypeStorage [forall a. Integer -> a -> EventHandlerWithID a
EventHandlerWithID Integer
id' StoredEHType ('CustomEvt x)
handler])
instance (Typeable s, EHStorageType s ~ [EventHandlerWithID (StoredEHType s)], Typeable (StoredEHType s)) => InsertEventHandler' 'False s where
makeEventHandlers' :: Proxy 'False
-> Proxy s -> Integer -> StoredEHType s -> EventHandlers
makeEventHandlers' Proxy 'False
_ Proxy s
_ Integer
id' StoredEHType s
handler = TypeRepMap EventHandler -> EventHandlers
EventHandlers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k) (f :: k -> *).
Typeable a =>
f a -> TypeRepMap f
TM.one forall a b. (a -> b) -> a -> b
$ forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH @s [forall a. Integer -> a -> EventHandlerWithID a
EventHandlerWithID Integer
id' StoredEHType s
handler]
class GetEventHandlers a where
getEventHandlers :: EventHandlers -> [StoredEHType a]
instance (EHInstanceSelector a ~ flag, GetEventHandlers' flag a) => GetEventHandlers a where
getEventHandlers :: EventHandlers -> [StoredEHType a]
getEventHandlers = forall (flag :: Bool) (a :: EventType).
GetEventHandlers' flag a =>
Proxy a -> Proxy flag -> EventHandlers -> [StoredEHType a]
getEventHandlers' (forall {k} (t :: k). Proxy t
Proxy @a) (forall {k} (t :: k). Proxy t
Proxy @flag)
class GetEventHandlers' (flag :: Bool) a where
getEventHandlers' :: Proxy a -> Proxy flag -> EventHandlers -> [StoredEHType a]
instance GetEventHandlers' 'True ( 'CustomEvt a) where
getEventHandlers' :: Proxy ('CustomEvt a)
-> Proxy 'True -> EventHandlers -> [StoredEHType ('CustomEvt a)]
getEventHandlers' Proxy ('CustomEvt a)
_ Proxy 'True
_ EventHandlers
_ = forall a. HasCallStack => String -> a
error String
"use getCustomEventHandlers instead"
instance (Typeable s, Typeable (StoredEHType s), EHStorageType s ~ [EventHandlerWithID (StoredEHType s)]) => GetEventHandlers' 'False s where
getEventHandlers' :: Proxy s -> Proxy 'False -> EventHandlers -> [StoredEHType s]
getEventHandlers' Proxy s
_ Proxy 'False
_ (EventHandlers TypeRepMap EventHandler
handlers) =
let theseHandlers :: EHStorageType s
theseHandlers = forall (t :: EventType).
EventHandler t
-> (Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t
unwrapEventHandler @s forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty (forall {k} (a :: k) (f :: k -> *).
Typeable a =>
TypeRepMap f -> Maybe (f a)
TM.lookup TypeRepMap EventHandler
handlers :: Maybe (EventHandler s))
in forall a b. (a -> b) -> [a] -> [b]
map forall a. EventHandlerWithID a -> a
eh EHStorageType s
theseHandlers
class RemoveEventHandler a where
removeEventHandler :: Proxy a -> Integer -> EventHandlers -> EventHandlers
instance (EHInstanceSelector a ~ flag, RemoveEventHandler' flag a) => RemoveEventHandler a where
removeEventHandler :: Proxy a -> Integer -> EventHandlers -> EventHandlers
removeEventHandler = forall {k} (flag :: Bool) (a :: k).
RemoveEventHandler' flag a =>
Proxy flag -> Proxy a -> Integer -> EventHandlers -> EventHandlers
removeEventHandler' (forall {k} (t :: k). Proxy t
Proxy @flag)
class RemoveEventHandler' (flag :: Bool) a where
removeEventHandler' :: Proxy flag -> Proxy a -> Integer -> EventHandlers -> EventHandlers
instance forall (a :: Type). (Typeable a) => RemoveEventHandler' 'True ( 'CustomEvt a) where
removeEventHandler' :: Proxy 'True
-> Proxy ('CustomEvt a)
-> Integer
-> EventHandlers
-> EventHandlers
removeEventHandler' Proxy 'True
_ Proxy ('CustomEvt a)
_ Integer
id' (EventHandlers TypeRepMap EventHandler
handlers) =
TypeRepMap EventHandler -> EventHandlers
EventHandlers forall a b. (a -> b) -> a -> b
$
forall {k} (a :: k) (f :: k -> *).
Typeable a =>
(f a -> f a) -> TypeRepMap f -> TypeRepMap f
TM.adjust @( 'CustomEvt Void)
( \(EH (Semigroup (EHStorageType ('CustomEvt Void)),
Monoid (EHStorageType ('CustomEvt Void))) =>
EHStorageType ('CustomEvt Void)
ehs) ->
forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH
( forall {k} (a :: k) (f :: k -> *).
Typeable a =>
(f a -> f a) -> TypeRepMap f -> TypeRepMap f
TM.adjust @a
(forall a.
[EventHandlerWithID (a -> IO ())] -> CustomEHTypeStorage a
CustomEHTypeStorage forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/= Integer
id') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. EventHandlerWithID a -> Integer
ehID) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
CustomEHTypeStorage a -> [EventHandlerWithID (a -> IO ())]
unwrapCustomEHTypeStorage)
(Semigroup (EHStorageType ('CustomEvt Void)),
Monoid (EHStorageType ('CustomEvt Void))) =>
EHStorageType ('CustomEvt Void)
ehs
)
)
TypeRepMap EventHandler
handlers
instance
(Typeable s, Typeable (StoredEHType s), EHStorageType s ~ [EventHandlerWithID (StoredEHType s)]) =>
RemoveEventHandler' 'False s
where
removeEventHandler' :: Proxy 'False
-> Proxy s -> Integer -> EventHandlers -> EventHandlers
removeEventHandler' Proxy 'False
_ Proxy s
_ Integer
id' (EventHandlers TypeRepMap EventHandler
handlers) =
TypeRepMap EventHandler -> EventHandlers
EventHandlers forall a b. (a -> b) -> a -> b
$
forall {k} (a :: k) (f :: k -> *).
Typeable a =>
(f a -> f a) -> TypeRepMap f -> TypeRepMap f
TM.adjust @s
(\(EH (Semigroup (EHStorageType s), Monoid (EHStorageType s)) =>
EHStorageType s
ehs) -> forall (t :: EventType).
((Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t)
-> EventHandler t
EH forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/= Integer
id') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. EventHandlerWithID a -> Integer
ehID) (Semigroup (EHStorageType s), Monoid (EHStorageType s)) =>
EHStorageType s
ehs)
TypeRepMap EventHandler
handlers
getCustomEventHandlers :: forall a. Typeable a => EventHandlers -> [a -> IO ()]
getCustomEventHandlers :: forall a. Typeable a => EventHandlers -> [a -> IO ()]
getCustomEventHandlers (EventHandlers TypeRepMap EventHandler
handlers) =
let handlerMap :: EHStorageType ('CustomEvt Void)
handlerMap =
forall (t :: EventType).
EventHandler t
-> (Semigroup (EHStorageType t), Monoid (EHStorageType t)) =>
EHStorageType t
unwrapEventHandler @( 'CustomEvt Void) forall a b. (a -> b) -> a -> b
$
forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty (forall {k} (a :: k) (f :: k -> *).
Typeable a =>
TypeRepMap f -> Maybe (f a)
TM.lookup TypeRepMap EventHandler
handlers :: Maybe (EventHandler ( 'CustomEvt Void)))
in forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (forall a b. (a -> b) -> [a] -> [b]
map forall a. EventHandlerWithID a -> a
eh forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
CustomEHTypeStorage a -> [EventHandlerWithID (a -> IO ())]
unwrapCustomEHTypeStorage) forall a b. (a -> b) -> a -> b
$ forall {k} (a :: k) (f :: k -> *).
Typeable a =>
TypeRepMap f -> Maybe (f a)
TM.lookup @a EHStorageType ('CustomEvt Void)
handlerMap
$(makeFieldLabelsNoPrefix ''Client)