diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Changelog for Calamity +## 0.1.8.0 + +*2020-05-15* + +* Did a large rework of how event handlers are stored internally. +* introduced `waitUntil` + ## 0.1.4.0 * Added back extra exports of `Calamity.Types.Partial` from diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -83,7 +83,7 @@ P.makeSem ''Counter -runCounterAtomic :: P.Member (P.Embed IO) r => P.Sem (Counter ': r) () -> P.Sem r () +runCounterAtomic :: P.Member (P.Embed IO) r => P.Sem (Counter ': r) a -> P.Sem r a runCounterAtomic m = do var <- P.embed $ newTVarIO (0 :: Int) P.runAtomicStateTVar var $ P.reinterpret (\case @@ -95,27 +95,23 @@ Left e -> DiP.error (e ^. packed) _ -> pure () -handleFailByPrinting m = do - r <- P.runFail m - case r of - Left e -> P.embed $ print (show e) - _ -> pure () - info = DiP.info @Text debug = DiP.info @Text +tellt :: (BotC r, Tellable t) => t -> Text -> P.Sem r (Either RestError Message) tellt = tell @Text main :: IO () main = do token <- view packed <$> getEnv "BOT_TOKEN" - P.runFinal . P.embedToFinal . handleFailByPrinting . runCounterAtomic . runCacheInMemory . runMetricsNoop - $ runBotIO (BotToken token) $ react @'MessageCreateEvt $ \msg -> handleFailByLogging $ do - when (msg ^. #content == "!count") $ replicateM_ 3 $ do + void . P.runFinal . P.embedToFinal . runCounterAtomic . runCacheInMemory . runMetricsPrometheusIO + $ runBotIO (BotToken token) $ do + react @'MessageCreateEvt $ \msg -> handleFailByLogging $ case msg ^. #content of + "!count" -> replicateM_ 3 $ do val <- getCounter info $ "the counter is: " <> showt val void $ tellt msg ("The value is: " <> showt val) - when (msg ^. #content == "!say hi") $ replicateM_ 3 . P.async $ do + "!say hi" -> replicateM_ 3 . P.async $ do info "saying heya" Right msg' <- tellt msg "heya" info "sleeping" @@ -123,10 +119,18 @@ info "slept" void . invoke $ EditMessage (msg ^. #channelID) msg' (Just "lol") Nothing info "edited" - when (msg ^. #content == "!explode") $ do + "!explode" -> do Just x <- pure Nothing debug "unreachable!" - when (msg ^. #content == "!bye") $ do + "!bye" -> do void $ tellt msg "bye!" stopBot + "!fire-evt" -> fire $ customEvt @"my-event" ("aha" :: Text, msg) + "!wait" -> do + void $ tellt msg "waiting for !continue" + waitUntil @'MessageCreateEvt (\msg -> (debug $ "got message: " <> showt msg) >> (pure $ msg ^. #content == "!continue")) + void $ tellt msg "got !continue" + _ -> pure () + react @('CustomEvt "my-event" (Text, Message)) $ \(s, m) -> + void $ tellt m ("Somebody told me to tell you about: " <> s) ``` diff --git a/calamity.cabal b/calamity.cabal --- a/calamity.cabal +++ b/calamity.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 0b61f91df75a0a06757763a207ce83d2a9597c059dadd7798a155ace29013568 +-- hash: 1217175ab8de3749a8fdae8f73f44a650fbb177f93f65f8c2d583dea7cffec7c name: calamity -version: 0.1.7.0 +version: 0.1.8.0 synopsis: A library for writing discord bots description: Please see the README on GitHub at category: Network, Web @@ -60,6 +60,8 @@ Calamity.HTTP.Webhook Calamity.Internal.AesonThings Calamity.Internal.BoundedStore + Calamity.Internal.GenericCurry + Calamity.Internal.RunIntoIO Calamity.Internal.SnowflakeMap Calamity.Internal.Updateable Calamity.Internal.Utils diff --git a/src/Calamity/Client/Client.hs b/src/Calamity/Client/Client.hs --- a/src/Calamity/Client/Client.hs +++ b/src/Calamity/Client/Client.hs @@ -8,6 +8,7 @@ , sendPresence , events , fire + , waitUntil , CalamityEvent(Dispatch, ShutDown) , customEvt ) where @@ -17,8 +18,10 @@ import Calamity.Gateway.DispatchEvents import Calamity.Gateway.Types import Calamity.HTTP.Internal.Ratelimit +import Calamity.Internal.GenericCurry import qualified Calamity.Internal.SnowflakeMap as SM import Calamity.Internal.Updateable +import Calamity.Internal.RunIntoIO import Calamity.Internal.Utils import Calamity.Metrics.Eff import Calamity.Types.Model.Channel @@ -30,12 +33,14 @@ import Control.Concurrent.Chan.Unagi import Control.Concurrent.MVar import Control.Concurrent.STM +import Control.Exception ( SomeException ) import Control.Lens import Control.Monad import Data.Default.Class import Data.Dynamic import Data.Foldable +import Data.IORef import Data.Maybe import Data.Proxy import Data.Time.Clock.POSIX @@ -62,12 +67,13 @@ pure (duration, res) -newClient :: Token -> IO Client -newClient token = do +newClient :: Token -> TypeRep -> IO Client +newClient token t = do shards' <- newTVarIO [] numShards' <- newEmptyMVar rlState' <- newRateLimitState (inc, outc) <- newChan + ehidCounter <- newIORef 0 pure $ Client shards' numShards' @@ -75,22 +81,30 @@ rlState' inc outc + ehidCounter + t -- | Create a bot, run your setup action, and then loop until the bot closes. --- --- This method has a 'P.Fail' effect to handle fatal errors that happen during --- setup (bad token, etc). -runBotIO :: (P.Members '[P.Embed IO, P.Final IO, P.Fail, CacheEff, MetricEff] r, Typeable r) => Token -> SetupEff r -> P.Sem r () +runBotIO :: forall r a. (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff] r, Typeable (SetupEff r)) => Token -> P.Sem (SetupEff r) a -> P.Sem r (Maybe StartupError) runBotIO token setup = do - client <- P.embed $ newClient token + client <- P.embed $ newClient token (typeRep $ Proxy @(SetupEff r)) handlers <- P.embed $ newTVarIO def P.asyncToIOFinal . P.runAtomicStateTVar handlers . P.runReader client . Di.runDiToStderrIO . Di.push "calamity" $ do - Di.push "calamity-setup" setup - shardBot - Di.push "calamity-loop" clientLoop - Di.push "calamity-stop" finishUp + void $ Di.push "calamity-setup" setup + r <- shardBot + case r of + Left e -> pure (Just e) + Right _ -> do + Di.push "calamity-loop" clientLoop + Di.push "calamity-stop" finishUp + pure Nothing --- | Register an event handler. +ehToIO :: forall r p. P.Member (P.Final IO) r => (p -> P.Sem r ()) -> P.Sem r (p -> IO ()) +ehToIO f = runIntoIOFinal go + where go :: P.Sem (IntoIO p ': r) (p -> IO ()) + go = intoIO (P.raise . f) + +-- | Register an event handler, returning an action that removes the event handler from the bot. -- -- Refer to 'EventType' for what events you can register, and 'EHType' for the -- parameters the event handlers they receive. @@ -118,10 +132,30 @@ -- This function is pretty bad for giving nasty type errors, -- since if something doesn't match then 'EHType' might not get substituted, -- which will result in errors about parameter counts mismatching. -react :: forall (s :: EventType) r. (BotC r, InsertEventHandler s (P.Sem r)) => EHType s (P.Sem r) -> P.Sem r () -react handler = let handlers = makeEventHandlers (Proxy @s) (Proxy @(P.Sem r)) handler - in P.atomicModify (handlers <>) +react :: forall (s :: EventType) r t eh ehIO. + (BotC r + , InsertEventHandler s + , RemoveEventHandler s + , eh ~ EHType s (P.Sem r) () + , ehIO ~ EHType s IO () + , Uncurry eh + , Uncurried eh ~ (t -> P.Sem r ()) + , Curry (t -> IO ()) + , ehIO ~ Curried (t -> IO ()) + ) + => eh + -> P.Sem r (P.Sem r ()) +react handler = do + handler' <- ehToIO (\(params :: t) -> (uncurryG handler params)) + ehidC <- P.asks (^. #ehidCounter) + id' <- P.embed $ atomicModifyIORef ehidC (\i -> (succ i, i)) + let handlers = makeEventHandlers (Proxy @s) id' (curryG handler') + P.atomicModify (handlers <>) + pure $ removeHandler @s id' +removeHandler :: forall (s :: EventType) r. (BotC r, RemoveEventHandler s) => Integer -> P.Sem r () +removeHandler id' = P.atomicModify (removeEventHandler (Proxy @s) id') + -- | Fire an event that the bot will then handle. -- -- ==== Examples @@ -159,6 +193,59 @@ inc <- P.asks (^. #eventsIn) P.embed $ dupChan inc +-- | Wait until an event satisfying a condition happens, then returns it's +-- parameters +-- +-- Sorry about this horrendous type sig, this is what it would look like with @s +-- ~ \''MessageCreateEvt'@: +-- +-- @ +-- 'waitUntil' :: ('Message' -> 'P.Sem' r 'Bool') -> 'P.Sem' r 'Message' +-- @ +-- +-- And for @s ~ \''MessageUpdateEvt'@: +-- +-- @ +-- 'waitUntil' :: ('Message' -> 'Message' -> 'P.Sem' r 'Bool') -> 'P.Sem' r ('Message', 'Message') +-- @ +-- +-- ==== Examples +-- +-- Waiting for a message containing the text \"hi\": +-- +-- @ +-- f = do msg \<\- 'waitUntil' @\''MessageCreateEvt' (\m -> 'pure' $ 'Data.Text.Lazy.isInfixOf' "hi" $ m ^. #content) +-- print $ msg ^. #content +-- @ +waitUntil + :: forall (s :: EventType) r t eh ehB. + ( BotC r + , InsertEventHandler s + , RemoveEventHandler s + , Uncurry eh + , eh ~ EHType s (P.Sem r) () + , eh ~ Curried (t -> P.Sem r ()) + , Uncurry ehB + , Uncurried ehB ~ (t -> P.Sem r Bool) + , Curry (t -> IO ()) + , Curried (t -> IO ()) ~ EHType s IO () + ) + => ehB + -> P.Sem r t +waitUntil f = do + result <- P.embed newEmptyMVar + remove <- react @s (curryG $ checker result) + res <- P.embed $ takeMVar result + remove + pure res + where + checker :: MVar t -> t -> P.Sem r () + checker result args = do + res <- uncurryG f args + debug $ "checker result: " +|| res ||+ "" + when res $ do + P.embed $ putMVar result args + -- | Set the bot's presence on all shards. sendPresence :: BotC r => StatusUpdateData -> P.Sem r () sendPresence s = do @@ -170,9 +257,6 @@ stopBot :: BotC r => P.Sem r () stopBot = do debug "stopping bot" - shards <- P.asks (^. #shards) >>= P.embed . readTVarIO - for_ shards $ \(inc, _) -> - P.embed $ writeChan inc ShutDownShard inc <- P.asks (^. #eventsIn) P.embed $ writeChan inc ShutDown @@ -180,6 +264,8 @@ finishUp = do debug "finishing up" shards <- P.asks (^. #shards) >>= P.embed . readTVarIO + for_ shards $ \(inc, _) -> + P.embed $ writeChan inc ShutDownShard for_ shards $ \(_, shardThread) -> P.await shardThread debug "bot has stopped" @@ -204,8 +290,15 @@ let handlers = getCustomEventHandlers s (dynTypeRep d) eventHandlers - for_ handlers (\h -> P.async . fromJust . fromDynamic @(P.Sem r ()) . fromJust $ dynApply h d) + for_ handlers (\h -> P.async . P.embed $ h d) +catchAllLogging :: BotC r => P.Sem r () -> P.Sem r () +catchAllLogging m = do + r <- P.errorToIOFinal . P.fromExceptionSem @SomeException $ P.raise m + case r of + Right _ -> pure () + Left e -> debug $ "got exception: " +|| e ||+ "" + handleEvent :: BotC r => DispatchData -> P.Sem r () handleEvent data' = do debug "handling an event" @@ -220,7 +313,7 @@ case actions of Right actions -> for_ actions $ \action -> P.async $ do - (time, _) <- timeA $ Di.reset action + (time, _) <- timeA . catchAllLogging $ P.embed action void $ observeHistogram time eventHandleHisto Left err -> debug $ "Failed handling actions for event: " +| err |+ "" @@ -236,7 +329,7 @@ handleEvent' :: BotC r => EventHandlers -> DispatchData - -> P.Sem (P.Fail ': r) [P.Sem r ()] + -> P.Sem (P.Fail ': r) [IO ()] handleEvent' eh evt@(Ready rd@ReadyData {}) = do updateCache evt pure $ map ($ rd) (getEventHandlers @'ReadyEvt eh) diff --git a/src/Calamity/Client/ShardManager.hs b/src/Calamity/Client/ShardManager.hs --- a/src/Calamity/Client/ShardManager.hs +++ b/src/Calamity/Client/ShardManager.hs @@ -21,9 +21,13 @@ import qualified Polysemy as P import qualified Polysemy.Reader as P +mapLeft :: (a -> c) -> Either a b -> Either c b +mapLeft f (Left a) = Left $ f a +mapLeft _ (Right b) = Right b + -- | Connects the bot to the gateway over n shards -shardBot :: (BotC r, P.Member P.Fail r) => Sem r () -shardBot = do +shardBot :: BotC r => Sem r (Either StartupError ()) +shardBot = (mapLeft StartupError <$>) . P.runFail $ do numShardsVar <- P.asks numShards shardsVar <- P.asks shards diff --git a/src/Calamity/Client/Types.hs b/src/Calamity/Client/Types.hs --- a/src/Calamity/Client/Types.hs +++ b/src/Calamity/Client/Types.hs @@ -1,12 +1,14 @@ -- | Types for the client module Calamity.Client.Types ( Client(..) + , StartupError(..) , EventType(..) , EHType , BotC , SetupEff , EventHandlers(..) , InsertEventHandler(..) + , RemoveEventHandler(..) , getEventHandlers , getCustomEventHandlers ) where @@ -29,8 +31,8 @@ import Data.Default.Class import Data.Dynamic -import Data.Functor import qualified Data.HashMap.Lazy as LH +import Data.IORef import Data.Maybe import Data.Time import qualified Data.TypeRepMap as TM @@ -47,12 +49,14 @@ import qualified Polysemy.Reader as P data Client = Client - { shards :: TVar [(InChan ControlMessage, Async (Maybe ()))] - , numShards :: MVar Int - , token :: Token - , rlState :: RateLimitState - , eventsIn :: InChan CalamityEvent - , eventsOut :: OutChan CalamityEvent + { shards :: TVar [(InChan ControlMessage, Async (Maybe ()))] + , numShards :: MVar Int + , token :: Token + , rlState :: RateLimitState + , eventsIn :: InChan CalamityEvent + , eventsOut :: OutChan CalamityEvent + , ehidCounter :: IORef Integer + , originalEffectsType :: TypeRep } deriving ( Generic ) @@ -62,8 +66,11 @@ , Typeable r) -- | A concrete effect stack used inside the bot -type SetupEff r = P.Sem (LogEff ': P.Reader Client ': P.AtomicState EventHandlers ': P.Async ': r) () +type SetupEff r = (LogEff ': P.Reader Client ': P.AtomicState EventHandlers ': P.Async ': r) +newtype StartupError = StartupError String + deriving ( Show ) + -- | A Data Kind used to fire custom events data EventType = ReadyEvt @@ -99,75 +106,51 @@ -- | A type family to decide what the parameters for an event handler should be -- determined by the type of event it is handling. -type family EHType (d :: EventType) m where - EHType 'ReadyEvt m = ReadyData -> m () - EHType 'ChannelCreateEvt m = Channel -> m () - EHType 'ChannelUpdateEvt m = Channel -> Channel -> m () - EHType 'ChannelDeleteEvt m = Channel -> m () - EHType 'ChannelpinsUpdateEvt m = Channel -> Maybe UTCTime -> m () - EHType 'GuildCreateEvt m = Guild -> Bool -> m () - EHType 'GuildUpdateEvt m = Guild -> Guild -> m () - EHType 'GuildDeleteEvt m = Guild -> Bool -> m () - EHType 'GuildBanAddEvt m = Guild -> User -> m () - EHType 'GuildBanRemoveEvt m = Guild -> User -> m () - EHType 'GuildEmojisUpdateEvt m = Guild -> [Emoji] -> m () - EHType 'GuildIntegrationsUpdateEvt m = Guild -> m () - EHType 'GuildMemberAddEvt m = Member -> m () - EHType 'GuildMemberRemoveEvt m = Member -> m () - EHType 'GuildMemberUpdateEvt m = Member -> Member -> m () - EHType 'GuildMembersChunkEvt m = Guild -> [Member] -> m () - EHType 'GuildRoleCreateEvt m = Guild -> Role -> m () - EHType 'GuildRoleUpdateEvt m = Guild -> Role -> Role -> m () - EHType 'GuildRoleDeleteEvt m = Guild -> Role -> m () - EHType 'MessageCreateEvt m = Message -> m () - EHType 'MessageUpdateEvt m = Message -> Message -> m () - EHType 'MessageDeleteEvt m = Message -> m () - EHType 'MessageDeleteBulkEvt m = [Message] -> m () - EHType 'MessageReactionAddEvt m = Message -> Reaction -> m () - EHType 'MessageReactionRemoveEvt m = Message -> Reaction -> m () - EHType 'MessageReactionRemoveAllEvt m = Message -> m () - EHType 'TypingStartEvt m = Channel -> Maybe Member -> UnixTimestamp -> m () - EHType 'UserUpdateEvt m = User -> User -> m () - EHType ('CustomEvt s a) m = a -> m () +type family EHType (d :: EventType) m r where + EHType 'ReadyEvt m r = ReadyData -> m r + EHType 'ChannelCreateEvt m r = Channel -> m r + EHType 'ChannelUpdateEvt m r = Channel -> Channel -> m r + EHType 'ChannelDeleteEvt m r = Channel -> m r + EHType 'ChannelpinsUpdateEvt m r = Channel -> Maybe UTCTime -> m r + EHType 'GuildCreateEvt m r = Guild -> Bool -> m r + EHType 'GuildUpdateEvt m r = Guild -> Guild -> m r + EHType 'GuildDeleteEvt m r = Guild -> Bool -> m r + EHType 'GuildBanAddEvt m r = Guild -> User -> m r + EHType 'GuildBanRemoveEvt m r = Guild -> User -> m r + EHType 'GuildEmojisUpdateEvt m r = Guild -> [Emoji] -> m r + EHType 'GuildIntegrationsUpdateEvt m r = Guild -> m r + EHType 'GuildMemberAddEvt m r = Member -> m r + EHType 'GuildMemberRemoveEvt m r = Member -> m r + EHType 'GuildMemberUpdateEvt m r = Member -> Member -> m r + EHType 'GuildMembersChunkEvt m r = Guild -> [Member] -> m r + EHType 'GuildRoleCreateEvt m r = Guild -> Role -> m r + EHType 'GuildRoleUpdateEvt m r = Guild -> Role -> Role -> m r + EHType 'GuildRoleDeleteEvt m r = Guild -> Role -> m r + EHType 'MessageCreateEvt m r = Message -> m r + EHType 'MessageUpdateEvt m r = Message -> Message -> m r + EHType 'MessageDeleteEvt m r = Message -> m r + EHType 'MessageDeleteBulkEvt m r = [Message] -> m r + EHType 'MessageReactionAddEvt m r = Message -> Reaction -> m r + EHType 'MessageReactionRemoveEvt m r = Message -> Reaction -> m r + EHType 'MessageReactionRemoveAllEvt m r = Message -> m r + EHType 'TypingStartEvt m r = Channel -> Maybe Member -> UnixTimestamp -> m r + EHType 'UserUpdateEvt m r = User -> User -> m r + EHType ('CustomEvt s a) m r = a -> m r -type family EHType' (d :: EventType) where - EHType' 'ReadyEvt = Dynamic - EHType' 'ChannelCreateEvt = Dynamic - EHType' 'ChannelUpdateEvt = Dynamic - EHType' 'ChannelDeleteEvt = Dynamic - EHType' 'ChannelpinsUpdateEvt = Dynamic - EHType' 'GuildCreateEvt = Dynamic - EHType' 'GuildUpdateEvt = Dynamic - EHType' 'GuildDeleteEvt = Dynamic - EHType' 'GuildBanAddEvt = Dynamic - EHType' 'GuildBanRemoveEvt = Dynamic - EHType' 'GuildEmojisUpdateEvt = Dynamic - EHType' 'GuildIntegrationsUpdateEvt = Dynamic - EHType' 'GuildMemberAddEvt = Dynamic - EHType' 'GuildMemberRemoveEvt = Dynamic - EHType' 'GuildMemberUpdateEvt = Dynamic - EHType' 'GuildMembersChunkEvt = Dynamic - EHType' 'GuildRoleCreateEvt = Dynamic - EHType' 'GuildRoleUpdateEvt = Dynamic - EHType' 'GuildRoleDeleteEvt = Dynamic - EHType' 'MessageCreateEvt = Dynamic - EHType' 'MessageUpdateEvt = Dynamic - EHType' 'MessageDeleteEvt = Dynamic - EHType' 'MessageDeleteBulkEvt = Dynamic - EHType' 'MessageReactionAddEvt = Dynamic - EHType' 'MessageReactionRemoveEvt = Dynamic - EHType' 'MessageReactionRemoveAllEvt = Dynamic - EHType' 'TypingStartEvt = Dynamic - EHType' 'UserUpdateEvt = Dynamic - EHType' ('CustomEvt _ _) = Dynamic +type StoredEHType t = EHType t IO () newtype EventHandlers = EventHandlers (TypeRepMap EventHandler) -type family EHStorageType t where - EHStorageType ('CustomEvt s a) = LH.HashMap TypeRep (LH.HashMap TypeRep [Dynamic]) - EHStorageType t = [EHType' t] +data EventHandlerWithID a = EventHandlerWithID + { ehID :: Integer + , eh :: a + } -newtype EventHandler t = EH +type family EHStorageType (t :: EventType) where + EHStorageType ('CustomEvt s a) = LH.HashMap TypeRep (LH.HashMap TypeRep [EventHandlerWithID (StoredEHType ('CustomEvt s a))]) + EHStorageType t = [EventHandlerWithID (StoredEHType t)] + +newtype EventHandler (t :: EventType) = EH { unwrapEventHandler :: (Semigroup (EHStorageType t), Monoid (EHStorageType t)) => EHStorageType t } @@ -206,7 +189,7 @@ , WrapTypeable $ EH @'MessageReactionRemoveAllEvt [] , WrapTypeable $ EH @'TypingStartEvt [] , WrapTypeable $ EH @'UserUpdateEvt [] - , WrapTypeable $ EH @('CustomEvt Void Void) LH.empty + , WrapTypeable $ EH @('CustomEvt Void Dynamic) LH.empty ] instance Semigroup EventHandlers where @@ -221,50 +204,79 @@ EHInstanceSelector ('CustomEvt _ _) = 'True EHInstanceSelector _ = 'False + +fromDynamicJust :: forall a. Typeable a => Dynamic -> a +fromDynamicJust d = case fromDynamic d of + Just x -> x + Nothing -> error $ "Extracting dynamic failed, wanted: " <> (show . typeRep $ Proxy @a) <> ", got: " <> (show $ dynTypeRep d) + + -- | A helper typeclass that is used to decide how to register regular -- events, and custom events which require storing in a map at runtime. -class InsertEventHandler a m where - makeEventHandlers :: Proxy a -> Proxy m -> EHType a m -> EventHandlers +class InsertEventHandler a where + makeEventHandlers :: Proxy a -> Integer -> StoredEHType a -> EventHandlers -instance (EHInstanceSelector a ~ flag, InsertEventHandler' flag a m) => InsertEventHandler a m where +instance (EHInstanceSelector a ~ flag, InsertEventHandler' flag a) => InsertEventHandler a where makeEventHandlers = makeEventHandlers' (Proxy @flag) -class InsertEventHandler' (flag :: Bool) a m where - makeEventHandlers' :: Proxy flag -> Proxy a -> Proxy m -> EHType a m -> EventHandlers +class InsertEventHandler' (flag :: Bool) a where + makeEventHandlers' :: Proxy flag -> Proxy a -> Integer -> StoredEHType a -> EventHandlers -instance (Typeable a, Typeable s, Typeable (EHType ('CustomEvt s a) m)) - => InsertEventHandler' 'True ('CustomEvt s a) m where - makeEventHandlers' _ _ _ handler = EventHandlers . TM.one $ EH @('CustomEvt Void Void) - (LH.singleton (typeRep $ Proxy @s) (LH.singleton (typeRep $ Proxy @a) [toDyn handler])) +intoDynFn :: forall a. Typeable a => (a -> IO ()) -> (Dynamic -> IO ()) +intoDynFn fn = \d -> fn $ fromDynamicJust d -instance (Typeable s, EHStorageType s ~ [Dynamic], Typeable (EHType s m)) => InsertEventHandler' 'False s m where - makeEventHandlers' _ _ _ handler = EventHandlers . TM.one $ EH @s [toDyn handler] +instance (Typeable a, Typeable s, Typeable (StoredEHType ('CustomEvt s a)), EHType ('CustomEvt s a) IO () ~ (a -> IO ())) + => InsertEventHandler' 'True ('CustomEvt s a) where + makeEventHandlers' _ _ id' handler = EventHandlers . TM.one $ EH @('CustomEvt Void Dynamic) + (LH.singleton (typeRep $ Proxy @s) (LH.singleton (typeRep $ Proxy @a) [EventHandlerWithID id' (intoDynFn handler)])) +instance (Typeable s, EHStorageType s ~ [EventHandlerWithID (StoredEHType s)], Typeable (StoredEHType s)) => InsertEventHandler' 'False s where + makeEventHandlers' _ _ id' handler = EventHandlers . TM.one $ EH @s [EventHandlerWithID id' handler] -class GetEventHandlers a m where - getEventHandlers :: EventHandlers -> [EHType a m] -instance (EHInstanceSelector a ~ flag, GetEventHandlers' flag a m) => GetEventHandlers a m where - getEventHandlers = getEventHandlers' (Proxy @a) (Proxy @m) (Proxy @flag) +class GetEventHandlers a where + getEventHandlers :: EventHandlers -> [StoredEHType a] -class GetEventHandlers' (flag :: Bool) a m where - getEventHandlers' :: Proxy a -> Proxy m -> Proxy flag -> EventHandlers -> [EHType a m] +instance (EHInstanceSelector a ~ flag, GetEventHandlers' flag a) => GetEventHandlers a where + getEventHandlers = getEventHandlers' (Proxy @a) (Proxy @flag) -instance (Typeable a, Typeable s, Typeable (EHType ('CustomEvt s a) m)) => GetEventHandlers' 'True ('CustomEvt s a) m where - getEventHandlers' _ _ _ (EventHandlers handlers) = - let handlerMap = unwrapEventHandler @('CustomEvt Void Void) $ fromJust - (TM.lookup handlers :: Maybe (EventHandler ('CustomEvt Void Void))) - in concat $ LH.lookup (typeRep $ Proxy @s) handlerMap >>= LH.lookup (typeRep $ Proxy @a) <&> map - (fromJust . fromDynamic) +class GetEventHandlers' (flag :: Bool) a where + getEventHandlers' :: Proxy a -> Proxy flag -> EventHandlers -> [StoredEHType a] -instance (Typeable s, Typeable (EHType s m), EHStorageType s ~ [Dynamic]) => GetEventHandlers' 'False s m where - getEventHandlers' _ _ _ (EventHandlers handlers) = +instance GetEventHandlers' 'True ('CustomEvt s a) where + getEventHandlers' _ _ _ = error "use getCustomEventHandlers instead" + -- let handlerMap = unwrapEventHandler @('CustomEvt Void Dynamic) $ fromJust + -- (TM.lookup handlers :: Maybe (EventHandler ('CustomEvt Void Dynamic))) + -- in concat $ LH.lookup (typeRep $ Proxy @s) handlerMap >>= LH.lookup (typeRep $ Proxy @a) <&> map eh + +instance (Typeable s, Typeable (StoredEHType s), EHStorageType s ~ [EventHandlerWithID (StoredEHType s)]) => GetEventHandlers' 'False s where + getEventHandlers' _ _ (EventHandlers handlers) = let theseHandlers = unwrapEventHandler @s $ fromJust (TM.lookup handlers :: Maybe (EventHandler s)) - in map (fromJust . fromDynamic) theseHandlers + in map eh theseHandlers -getCustomEventHandlers :: TypeRep -> TypeRep -> EventHandlers -> [Dynamic] +class RemoveEventHandler a where + removeEventHandler :: Proxy a -> Integer -> EventHandlers -> EventHandlers + +instance (EHInstanceSelector a ~ flag, RemoveEventHandler' flag a) => RemoveEventHandler a where + removeEventHandler = removeEventHandler' (Proxy @flag) + +class RemoveEventHandler' (flag :: Bool) a where + removeEventHandler' :: Proxy flag -> Proxy a -> Integer -> EventHandlers -> EventHandlers + +instance (Typeable s, Typeable a) => RemoveEventHandler' 'True ('CustomEvt s a) where + removeEventHandler' _ _ id' (EventHandlers handlers) = EventHandlers $ TM.adjust @('CustomEvt Void Dynamic) + (\(EH ehs) -> EH (LH.update (Just . LH.update (Just . filter ((/= id') . ehID)) (typeRep $ Proxy @a)) + (typeRep $ Proxy @s) ehs)) handlers + +instance (Typeable s, Typeable (StoredEHType s), EHStorageType s ~ [EventHandlerWithID (StoredEHType s)]) + => RemoveEventHandler' 'False s where + removeEventHandler' _ _ id' (EventHandlers handlers) = EventHandlers $ TM.adjust @s + (\(EH ehs) -> EH $ filter ((/= id') . ehID) ehs) handlers + + +getCustomEventHandlers :: TypeRep -> TypeRep -> EventHandlers -> [Dynamic -> IO ()] getCustomEventHandlers s a (EventHandlers handlers) = - let handlerMap = unwrapEventHandler @('CustomEvt Void Void) $ fromJust - (TM.lookup handlers :: Maybe (EventHandler ('CustomEvt Void Void))) - in concat $ LH.lookup s handlerMap >>= LH.lookup a + let handlerMap = unwrapEventHandler @('CustomEvt Void Dynamic) $ fromJust + (TM.lookup handlers :: Maybe (EventHandler ('CustomEvt Void Dynamic))) + in map eh . concat $ LH.lookup s handlerMap >>= LH.lookup a diff --git a/src/Calamity/Internal/GenericCurry.hs b/src/Calamity/Internal/GenericCurry.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Internal/GenericCurry.hs @@ -0,0 +1,115 @@ +-- | Generic arity curry/ uncurry +module Calamity.Internal.GenericCurry + ( Curry(..) + , Uncurry(..) ) where + +import Data.Typeable + +import GHC.TypeNats + +class Curry t where + type Curried t + type Parameters t + + curryG :: t -> Curried t + +type family CurryInstanceSelector t :: Nat where + CurryInstanceSelector (a -> b -> c -> d -> e -> f -> r) = 6 + CurryInstanceSelector (a -> b -> c -> d -> e -> r) = 5 + CurryInstanceSelector (a -> b -> c -> d -> r) = 4 + CurryInstanceSelector (a -> b -> c -> r) = 3 + CurryInstanceSelector (a -> b -> r) = 2 + CurryInstanceSelector (a -> r) = 1 + +class Curry' (flag :: Nat) t where + type Curried' (flag :: Nat) t + type Parameters' (flag :: Nat) t + + curryG' :: Proxy flag -> t -> Curried' flag t + +instance (CurryInstanceSelector t ~ flag, Curry' flag t) => Curry t where + type Curried t = Curried' (CurryInstanceSelector t) t + type Parameters t = Parameters' (CurryInstanceSelector t) t + + curryG = curryG' (Proxy @flag) + +instance Curry' 6 ((a, b, c, d, e, f) -> r) where + type Curried' 6 ((a, b, c, d, e, f) -> r) = a -> b -> c -> d -> e -> f -> r + type Parameters' 6 ((a, b, c, d, e, f) -> r) = (a, b, c, d, e, f) + + curryG' _ fn a b c d e f = fn (a, b, c, d, e, f) + +instance Curry' 5 ((a, b, c, d, e) -> r) where + type Curried' 5 ((a, b, c, d, e) -> r) = a -> b -> c -> d -> e -> r + type Parameters' 5 ((a, b, c, d, e) -> r) = (a, b, c, d, e) + + curryG' _ fn a b c d e = fn (a, b, c, d, e) + +instance Curry' 4 ((a, b, c, d) -> r) where + type Curried' 4 ((a, b, c, d) -> r) = a -> b -> c -> d -> r + type Parameters' 4 ((a, b, c, d) -> r) = (a, b, c, d) + + curryG' _ fn a b c d = fn (a, b, c, d) + +instance Curry' 3 ((a, b, c) -> r) where + type Curried' 3 ((a, b, c) -> r) = a -> b -> c -> r + type Parameters' 3 ((a, b, c) -> r) = (a, b, c) + + curryG' _ fn a b c = fn (a, b, c) + +instance Curry' 2 ((a, b) -> r) where + type Curried' 2 ((a, b) -> r) = a -> b -> r + type Parameters' 2 ((a, b) -> r) = (a, b) + + curryG' _ fn a b = fn (a, b) + +instance Curry' 1 (a -> r) where + type Curried' 1 (a -> r) = a -> r + type Parameters' 1 (a -> r) = a + + curryG' _ fn = fn + +class Uncurry t where + type Uncurried t + + uncurryG :: t -> Uncurried t + +class Uncurry' (flag :: Nat) t where + type Uncurried' (flag :: Nat) t + + uncurryG' :: Proxy flag -> t -> Uncurried' flag t + +instance (CurryInstanceSelector t ~ flag, Uncurry' flag t) => Uncurry t where + type Uncurried t = Uncurried' (CurryInstanceSelector t) t + + uncurryG = uncurryG' (Proxy @flag) + +instance Uncurry' 6 (a -> b -> c -> d -> e -> f -> r) where + type Uncurried' 6 (a -> b -> c -> d -> e -> f -> r) = (a, b, c, d, e, f) -> r + + uncurryG' _ fn (a, b, c, d, e, f) = fn a b c d e f + +instance Uncurry' 5 (a -> b -> c -> d -> e -> r) where + type Uncurried' 5 (a -> b -> c -> d -> e -> r) = (a, b, c, d, e) -> r + + uncurryG' _ f (a, b, c, d, e) = f a b c d e + +instance Uncurry' 4 (a -> b -> c -> d -> r) where + type Uncurried' 4 (a -> b -> c -> d -> r) = (a, b, c, d) -> r + + uncurryG' _ f (a, b, c, d) = f a b c d + +instance Uncurry' 3 (a -> b -> c -> r) where + type Uncurried' 3 (a -> b -> c -> r) = (a, b, c) -> r + + uncurryG' _ f (a, b, c) = f a b c + +instance Uncurry' 2 (a -> b -> r) where + type Uncurried' 2 (a -> b -> r) = (a, b) -> r + + uncurryG' _ f (a, b) = f a b + +instance Uncurry' 1 (a -> r) where + type Uncurried' 1 (a -> r) = a -> r + + uncurryG' _ f = f diff --git a/src/Calamity/Internal/RunIntoIO.hs b/src/Calamity/Internal/RunIntoIO.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Internal/RunIntoIO.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Something for converting polysemy actions into IO actions +module Calamity.Internal.RunIntoIO + ( IntoIO(..) + , runIntoIOFinal + , intoIO ) where + +import Control.Monad + +import Data.Functor + +import qualified Polysemy as P +import qualified Polysemy.Final as P + +data IntoIO p m a where + IntoIO :: (p -> m ()) -> IntoIO p m (p -> IO ()) + +runIntoIOFinal :: forall r p a. P.Member (P.Final IO) r => P.Sem (IntoIO p ': r) a -> P.Sem r a +runIntoIOFinal = P.interpretFinal $ \case + IntoIO m -> do + istate <- P.getInitialStateS + m' <- P.bindS m + P.liftS $ pure (\x -> void (m' $ istate $> x)) + +P.makeSem ''IntoIO