calamity 0.1.7.0 → 0.1.8.0

raw patch · 8 files changed

+404/−141 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−0
• README.md +17/−13
• calamity.cabal +4/−2
• src/Calamity/Client/Client.hs +114/−21
• src/Calamity/Client/ShardManager.hs +6/−2
• src/Calamity/Client/Types.hs +115/−103
• src/Calamity/Internal/GenericCurry.hs +115/−0
• src/Calamity/Internal/RunIntoIO.hs +26/−0

@@ -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

@@ -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) ```

@@ -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 <https://github.com/nitros12/calamity#readme> 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

@@ -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)

@@ -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 

@@ -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

@@ -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

@@ -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